Theory Auxiliary
chapter ‹Jinja Source Language \label{cha:j}›
section ‹Auxiliary Definitions›
theory Auxiliary imports Main begin
lemma nat_add_max_le[simp]:
"((n::nat) + max i j ≤ m) = (n + i ≤ m ∧ n + j ≤ m)"
by arith
lemma Suc_add_max_le[simp]:
"(Suc(n + max i j) ≤ m) = (Suc(n + i) ≤ m ∧ Suc(n + j) ≤ m)"
by arith
notation Some ("(⌊_⌋)")
declare
option.splits[split]
Let_def[simp]
subset_insertI2 [simp]
Cons_eq_map_conv [iff]
subsection ‹‹distinct_fst››
definition distinct_fst :: "('a × 'b) list ⇒ bool"
where
"distinct_fst ≡ distinct ∘ map fst"
lemma distinct_fst_Nil [simp]:
"distinct_fst []"
apply (unfold distinct_fst_def)
apply (simp (no_asm))
done
lemma distinct_fst_Cons [simp]:
"distinct_fst ((k,x)#kxs) = (distinct_fst kxs ∧ (∀y. (k,y) ∉ set kxs))"
apply (unfold distinct_fst_def)
apply (auto simp:image_def)
done
lemma map_of_SomeI:
"⟦ distinct_fst kxs; (k,x) ∈ set kxs ⟧ ⟹ map_of kxs k = Some x"
by (induct kxs) (auto simp:fun_upd_apply)
subsection ‹Using @{term list_all2} for relations›
definition fun_of :: "('a × 'b) set ⇒ 'a ⇒ 'b ⇒ bool"
where
"fun_of S ≡ λx y. (x,y) ∈ S"
text ‹Convenience lemmas›
declare fun_of_def [simp]
lemma rel_list_all2_Cons [iff]:
"list_all2 (fun_of S) (x#xs) (y#ys) =
((x,y) ∈ S ∧ list_all2 (fun_of S) xs ys)"
by simp
lemma rel_list_all2_Cons1:
"list_all2 (fun_of S) (x#xs) ys =
(∃z zs. ys = z#zs ∧ (x,z) ∈ S ∧ list_all2 (fun_of S) xs zs)"
by (cases ys) auto
lemma rel_list_all2_Cons2:
"list_all2 (fun_of S) xs (y#ys) =
(∃z zs. xs = z#zs ∧ (z,y) ∈ S ∧ list_all2 (fun_of S) zs ys)"
by (cases xs) auto
lemma rel_list_all2_refl:
"(⋀x. (x,x) ∈ S) ⟹ list_all2 (fun_of S) xs xs"
by (simp add: list_all2_refl)
lemma rel_list_all2_antisym:
"⟦ (⋀x y. ⟦(x,y) ∈ S; (y,x) ∈ T⟧ ⟹ x = y);
list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs ⟧ ⟹ xs = ys"
by (rule list_all2_antisym) auto
lemma rel_list_all2_trans:
"⟦ ⋀a b c. ⟦(a,b) ∈ R; (b,c) ∈ S⟧ ⟹ (a,c) ∈ T;
list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs⟧
⟹ list_all2 (fun_of T) as cs"
by (rule list_all2_trans) auto
lemma rel_list_all2_update_cong:
"⟦ i<size xs; list_all2 (fun_of S) xs ys; (x,y) ∈ S ⟧
⟹ list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
by (simp add: list_all2_update_cong)
lemma rel_list_all2_nthD:
"⟦ list_all2 (fun_of S) xs ys; p < size xs ⟧ ⟹ (xs!p,ys!p) ∈ S"
by (drule list_all2_nthD) auto
lemma rel_list_all2I:
"⟦ length a = length b; ⋀n. n < length a ⟹ (a!n,b!n) ∈ S ⟧ ⟹ list_all2 (fun_of S) a b"
by (erule list_all2_all_nthI) simp
declare fun_of_def [simp del]
end
Theory Type
section ‹Jinja types›
theory Type imports Auxiliary begin
type_synonym cname = string
type_synonym mname = string
type_synonym vname = string
definition Object :: cname
where
"Object ≡ ''Object''"
definition this :: vname
where
"this ≡ ''this''"
datatype ty
= Void
| Boolean
| Integer
| NT
| Class cname
definition is_refT :: "ty ⇒ bool"
where
"is_refT T ≡ T = NT ∨ (∃C. T = Class C)"
lemma [iff]: "is_refT NT"
by(simp add:is_refT_def)
lemma [iff]: "is_refT(Class C)"
by(simp add:is_refT_def)
lemma refTE:
"⟦is_refT T; T = NT ⟹ P; ⋀C. T = Class C ⟹ P ⟧ ⟹ P"
by (auto simp add: is_refT_def)
lemma not_refTE:
"⟦ ¬is_refT T; T = Void ∨ T = Boolean ∨ T = Integer ⟹ P ⟧ ⟹ P"
by (cases T, auto simp add: is_refT_def)
end
Theory Decl
section ‹Class Declarations and Programs›
theory Decl imports Type begin
type_synonym
fdecl = "vname × ty"
type_synonym
'm mdecl = "mname × ty list × ty × 'm"
type_synonym
'm "class" = "cname × fdecl list × 'm mdecl list"
type_synonym
'm cdecl = "cname × 'm class"
type_synonym
'm prog = "'m cdecl list"
translations
(type) "fdecl" <= (type) "vname × ty"
(type) "'c mdecl" <= (type) "mname × ty list × ty × 'c"
(type) "'c class" <= (type) "cname × fdecl list × ('c mdecl) list"
(type) "'c cdecl" <= (type) "cname × ('c class)"
(type) "'c prog" <= (type) "('c cdecl) list"
definition "class" :: "'m prog ⇒ cname ⇀ 'm class"
where
"class ≡ map_of"
definition is_class :: "'m prog ⇒ cname ⇒ bool"
where
"is_class P C ≡ class P C ≠ None"
lemma finite_is_class: "finite {C. is_class P C}"
apply (unfold is_class_def class_def)
apply (fold dom_def)
apply (rule finite_dom_map_of)
done
definition is_type :: "'m prog ⇒ ty ⇒ bool"
where
"is_type P T ≡
(case T of Void ⇒ True | Boolean ⇒ True | Integer ⇒ True | NT ⇒ True
| Class C ⇒ is_class P C)"
lemma is_type_simps [simp]:
"is_type P Void ∧ is_type P Boolean ∧ is_type P Integer ∧
is_type P NT ∧ is_type P (Class C) = is_class P C"
by(simp add:is_type_def)
abbreviation
"types P == Collect (is_type P)"
end
Theory TypeRel
section ‹Relations between Jinja Types›
theory TypeRel imports
"HOL-Library.Transitive_Closure_Table"
Decl
begin
subsection‹The subclass relations›
inductive_set
subcls1 :: "'m prog ⇒ (cname × cname) set"
and subcls1' :: "'m prog ⇒ [cname, cname] ⇒ bool" ("_ ⊢ _ ≺⇧1 _" [71,71,71] 70)
for P :: "'m prog"
where
"P ⊢ C ≺⇧1 D ≡ (C,D) ∈ subcls1 P"
| subcls1I: "⟦class P C = Some (D,rest); C ≠ Object⟧ ⟹ P ⊢ C ≺⇧1 D"
abbreviation
subcls :: "'m prog ⇒ [cname, cname] ⇒ bool" ("_ ⊢ _ ≼⇧* _" [71,71,71] 70)
where "P ⊢ C ≼⇧* D ≡ (C,D) ∈ (subcls1 P)⇧*"
lemma subcls1D: "P ⊢ C ≺⇧1 D ⟹ C ≠ Object ∧ (∃fs ms. class P C = Some (D,fs,ms))"
by(erule subcls1.induct)(fastforce simp add:is_class_def)
lemma [iff]: "¬ P ⊢ Object ≺⇧1 C"
by(fastforce dest:subcls1D)
lemma [iff]: "(P ⊢ Object ≼⇧* C) = (C = Object)"
apply(rule iffI)
apply(erule converse_rtranclE)
apply simp_all
done
lemma subcls1_def2:
"subcls1 P =
(SIGMA C:{C. is_class P C}. {D. C≠Object ∧ fst (the (class P C))=D})"
by (fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
lemma finite_subcls1: "finite (subcls1 P)"
apply (simp add: subcls1_def2)
apply(rule finite_SigmaI [OF finite_is_class])
apply(rule_tac B = "{fst (the (class P C))}" in finite_subset)
apply auto
done
subsection‹The subtype relations›
inductive
widen :: "'m prog ⇒ ty ⇒ ty ⇒ bool" ("_ ⊢ _ ≤ _" [71,71,71] 70)
for P :: "'m prog"
where
widen_refl[iff]: "P ⊢ T ≤ T"
| widen_subcls: "P ⊢ C ≼⇧* D ⟹ P ⊢ Class C ≤ Class D"
| widen_null[iff]: "P ⊢ NT ≤ Class C"
abbreviation
widens :: "'m prog ⇒ ty list ⇒ ty list ⇒ bool"
("_ ⊢ _ [≤] _" [71,71,71] 70) where
"widens P Ts Ts' ≡ list_all2 (widen P) Ts Ts'"
lemma [iff]: "(P ⊢ T ≤ Void) = (T = Void)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ T ≤ Boolean) = (T = Boolean)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ T ≤ Integer) = (T = Integer)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ Void ≤ T) = (T = Void)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ Boolean ≤ T) = (T = Boolean)"
by (auto elim: widen.cases)
lemma [iff]: "(P ⊢ Integer ≤ T) = (T = Integer)"
by (auto elim: widen.cases)
lemma Class_widen: "P ⊢ Class C ≤ T ⟹ ∃D. T = Class D"
apply (ind_cases "P ⊢ Class C ≤ T")
apply auto
done
lemma [iff]: "(P ⊢ T ≤ NT) = (T = NT)"
apply(cases T)
apply(auto dest:Class_widen)
done
lemma Class_widen_Class [iff]: "(P ⊢ Class C ≤ Class D) = (P ⊢ C ≼⇧* D)"
apply (rule iffI)
apply (ind_cases "P ⊢ Class C ≤ Class D")
apply (auto elim: widen_subcls)
done
lemma widen_Class: "(P ⊢ T ≤ Class C) = (T = NT ∨ (∃D. T = Class D ∧ P ⊢ D ≼⇧* C))"
by(induct T, auto)
lemma widen_trans[trans]: "⟦P ⊢ S ≤ U; P ⊢ U ≤ T⟧ ⟹ P ⊢ S ≤ T"
proof -
assume "P⊢S ≤ U" thus "⋀T. P ⊢ U ≤ T ⟹ P ⊢ S ≤ T"
proof induct
case (widen_refl T T') thus "P ⊢ T ≤ T'" .
next
case (widen_subcls C D T)
then obtain E where "T = Class E" by (blast dest: Class_widen)
with widen_subcls show "P ⊢ Class C ≤ T" by (auto elim: rtrancl_trans)
next
case (widen_null C RT)
then obtain D where "RT = Class D" by (blast dest: Class_widen)
thus "P ⊢ NT ≤ RT" by auto
qed
qed
lemma widens_trans [trans]: "⟦P ⊢ Ss [≤] Ts; P ⊢ Ts [≤] Us⟧ ⟹ P ⊢ Ss [≤] Us"
by (rule list_all2_trans, rule widen_trans)
lemmas widens_refl [iff] = list_all2_refl [of "widen P", OF widen_refl] for P
lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P
subsection‹Method lookup›
inductive
Methods :: "['m prog, cname, mname ⇀ (ty list × ty × 'm) × cname] ⇒ bool"
("_ ⊢ _ sees'_methods _" [51,51,51] 50)
for P :: "'m prog"
where
sees_methods_Object:
"⟦ class P Object = Some(D,fs,ms); Mm = map_option (λm. (m,Object)) ∘ map_of ms ⟧
⟹ P ⊢ Object sees_methods Mm"
| sees_methods_rec:
"⟦ class P C = Some(D,fs,ms); C ≠ Object; P ⊢ D sees_methods Mm;
Mm' = Mm ++ (map_option (λm. (m,C)) ∘ map_of ms) ⟧
⟹ P ⊢ C sees_methods Mm'"
lemma sees_methods_fun:
assumes 1: "P ⊢ C sees_methods Mm"
shows "⋀Mm'. P ⊢ C sees_methods Mm' ⟹ Mm' = Mm"
using 1
proof induct
case (sees_methods_rec C D fs ms Dres Cres Cres')
have "class": "class P C = Some (D, fs, ms)"
and notObj: "C ≠ Object" and Dmethods: "P ⊢ D sees_methods Dres"
and IH: "⋀Dres'. P ⊢ D sees_methods Dres' ⟹ Dres' = Dres"
and Cres: "Cres = Dres ++ (map_option (λm. (m,C)) ∘ map_of ms)"
and Cmethods': "P ⊢ C sees_methods Cres'" by fact+
from Cmethods' notObj "class" obtain Dres'
where Dmethods': "P ⊢ D sees_methods Dres'"
and Cres': "Cres' = Dres' ++ (map_option (λm. (m,C)) ∘ map_of ms)"
by(auto elim: Methods.cases)
from Cres Cres' IH[OF Dmethods'] show "Cres' = Cres" by simp
next
case sees_methods_Object thus ?case by(auto elim: Methods.cases)
qed
lemma visible_methods_exist:
"P ⊢ C sees_methods Mm ⟹ Mm M = Some(m,D) ⟹
(∃D' fs ms. class P D = Some(D',fs,ms) ∧ map_of ms M = Some m)"
by(induct rule:Methods.induct) auto
lemma sees_methods_decl_above:
assumes Csees: "P ⊢ C sees_methods Mm"
shows "Mm M = Some(m,D) ⟹ P ⊢ C ≼⇧* D"
using Csees
proof induct
case sees_methods_Object thus ?case by auto
next
case sees_methods_rec thus ?case
by(fastforce simp:map_option_case split:option.splits
elim:converse_rtrancl_into_rtrancl[OF subcls1I])
qed
lemma sees_methods_idemp:
assumes Cmethods: "P ⊢ C sees_methods Mm"
shows "⋀m D. Mm M = Some(m,D) ⟹
∃Mm'. (P ⊢ D sees_methods Mm') ∧ Mm' M = Some(m,D)"
using Cmethods
proof induct
case sees_methods_Object thus ?case
by(fastforce dest: Methods.sees_methods_Object)
next
case sees_methods_rec thus ?case
by(fastforce split:option.splits dest: Methods.sees_methods_rec)
qed
lemma sees_methods_decl_mono:
assumes sub: "P ⊢ C' ≼⇧* C"
shows "P ⊢ C sees_methods Mm ⟹
∃Mm' Mm⇩2. P ⊢ C' sees_methods Mm' ∧ Mm' = Mm ++ Mm⇩2 ∧
(∀M m D. Mm⇩2 M = Some(m,D) ⟶ P ⊢ D ≼⇧* C)"
(is "_ ⟹ ∃Mm' Mm2. ?Q C' C Mm' Mm2")
using sub
proof (induct rule:converse_rtrancl_induct)
assume "P ⊢ C sees_methods Mm"
hence "?Q C C Mm Map.empty" by simp
thus "∃Mm' Mm2. ?Q C C Mm' Mm2" by blast
next
fix C'' C'
assume sub1: "P ⊢ C'' ≺⇧1 C'" and sub: "P ⊢ C' ≼⇧* C"
and IH: "P ⊢ C sees_methods Mm ⟹
∃Mm' Mm2. P ⊢ C' sees_methods Mm' ∧
Mm' = Mm ++ Mm2 ∧ (∀M m D. Mm2 M = Some(m,D) ⟶ P ⊢ D ≼⇧* C)"
and Csees: "P ⊢ C sees_methods Mm"
from IH[OF Csees] obtain Mm' Mm2 where C'sees: "P ⊢ C' sees_methods Mm'"
and Mm': "Mm' = Mm ++ Mm2"
and subC:"∀M m D. Mm2 M = Some(m,D) ⟶ P ⊢ D ≼⇧* C" by blast
obtain fs ms where "class": "class P C'' = Some(C',fs,ms)" "C'' ≠ Object"
using subcls1D[OF sub1] by blast
let ?Mm3 = "map_option (λm. (m,C'')) ∘ map_of ms"
have "P ⊢ C'' sees_methods (Mm ++ Mm2) ++ ?Mm3"
using sees_methods_rec[OF "class" C'sees refl] Mm' by simp
hence "?Q C'' C ((Mm ++ Mm2) ++ ?Mm3) (Mm2++?Mm3)"
using converse_rtrancl_into_rtrancl[OF sub1 sub]
by simp (simp add:map_add_def subC split:option.split)
thus "∃Mm' Mm2. ?Q C'' C Mm' Mm2" by blast
qed
definition Method :: "'m prog ⇒ cname ⇒ mname ⇒ ty list ⇒ ty ⇒ 'm ⇒ cname ⇒ bool"
("_ ⊢ _ sees _: _→_ = _ in _" [51,51,51,51,51,51,51] 50)
where
"P ⊢ C sees M: Ts→T = m in D ≡
∃Mm. P ⊢ C sees_methods Mm ∧ Mm M = Some((Ts,T,m),D)"
definition has_method :: "'m prog ⇒ cname ⇒ mname ⇒ bool" ("_ ⊢ _ has _" [51,0,51] 50)
where
"P ⊢ C has M ≡ ∃Ts T m D. P ⊢ C sees M:Ts→T = m in D"
lemma sees_method_fun:
"⟦P ⊢ C sees M:TS→T = m in D; P ⊢ C sees M:TS'→T' = m' in D' ⟧
⟹ TS' = TS ∧ T' = T ∧ m' = m ∧ D' = D"
by(fastforce dest: sees_methods_fun simp:Method_def)
lemma sees_method_decl_above:
"P ⊢ C sees M:Ts→T = m in D ⟹ P ⊢ C ≼⇧* D"
by(clarsimp simp:Method_def sees_methods_decl_above)
lemma visible_method_exists:
"P ⊢ C sees M:Ts→T = m in D ⟹
∃D' fs ms. class P D = Some(D',fs,ms) ∧ map_of ms M = Some(Ts,T,m)"
by(fastforce simp:Method_def dest!: visible_methods_exist)
lemma sees_method_idemp:
"P ⊢ C sees M:Ts→T=m in D ⟹ P ⊢ D sees M:Ts→T=m in D"
by(fastforce simp: Method_def intro:sees_methods_idemp)
lemma sees_method_decl_mono:
"⟦ P ⊢ C' ≼⇧* C; P ⊢ C sees M:Ts→T = m in D;
P ⊢ C' sees M:Ts'→T' = m' in D' ⟧ ⟹ P ⊢ D' ≼⇧* D"
apply(frule sees_method_decl_above)
apply(unfold Method_def)
apply clarsimp
apply(drule (1) sees_methods_decl_mono)
apply clarsimp
apply(drule (1) sees_methods_fun)
apply clarsimp
apply(blast intro:rtrancl_trans)
done
lemma sees_method_is_class:
"⟦ P ⊢ C sees M:Ts→T = m in D ⟧ ⟹ is_class P C"
by (auto simp add: is_class_def Method_def elim: Methods.induct)
subsection‹Field lookup›
inductive
Fields :: "['m prog, cname, ((vname × cname) × ty) list] ⇒ bool"
("_ ⊢ _ has'_fields _" [51,51,51] 50)
for P :: "'m prog"
where
has_fields_rec:
"⟦ class P C = Some(D,fs,ms); C ≠ Object; P ⊢ D has_fields FDTs;
FDTs' = map (λ(F,T). ((F,C),T)) fs @ FDTs ⟧
⟹ P ⊢ C has_fields FDTs'"
| has_fields_Object:
"⟦ class P Object = Some(D,fs,ms); FDTs = map (λ(F,T). ((F,Object),T)) fs ⟧
⟹ P ⊢ Object has_fields FDTs"
lemma has_fields_fun:
assumes 1: "P ⊢ C has_fields FDTs"
shows "⋀FDTs'. P ⊢ C has_fields FDTs' ⟹ FDTs' = FDTs"
using 1
proof induct
case (has_fields_rec C D fs ms Dres Cres Cres')
have "class": "class P C = Some (D, fs, ms)"
and notObj: "C ≠ Object" and DFields: "P ⊢ D has_fields Dres"
and IH: "⋀Dres'. P ⊢ D has_fields Dres' ⟹ Dres' = Dres"
and Cres: "Cres = map (λ(F,T). ((F,C),T)) fs @ Dres"
and CFields': "P ⊢ C has_fields Cres'" by fact+
from CFields' notObj "class" obtain Dres'
where DFields': "P ⊢ D has_fields Dres'"
and Cres': "Cres' = map (λ(F,T). ((F,C),T)) fs @ Dres'"
by(auto elim: Fields.cases)
from Cres Cres' IH[OF DFields'] show "Cres' = Cres" by simp
next
case has_fields_Object thus ?case by(auto elim: Fields.cases)
qed
lemma all_fields_in_has_fields:
assumes sub: "P ⊢ C has_fields FDTs"
shows "⟦ P ⊢ C ≼⇧* D; class P D = Some(D',fs,ms); (F,T) ∈ set fs ⟧
⟹ ((F,D),T) ∈ set FDTs"
using sub apply(induct)
apply(simp add:image_def)
apply(erule converse_rtranclE)
apply(force)
apply(drule subcls1D)
apply fastforce
apply(force simp:image_def)
done
lemma has_fields_decl_above:
assumes fields: "P ⊢ C has_fields FDTs"
shows "((F,D),T) ∈ set FDTs ⟹ P ⊢ C ≼⇧* D"
using fields apply(induct)
prefer 2 apply fastforce
apply clarsimp
apply(erule disjE)
apply(clarsimp simp add:image_def)
apply simp
apply(blast dest:subcls1I converse_rtrancl_into_rtrancl)
done
lemma subcls_notin_has_fields:
assumes fields: "P ⊢ C has_fields FDTs"
shows "((F,D),T) ∈ set FDTs ⟹ (D,C) ∉ (subcls1 P)⇧+"
using fields apply(induct)
prefer 2 apply(fastforce dest: tranclD)
apply clarsimp
apply(erule disjE)
apply(clarsimp simp add:image_def)
apply(drule tranclD)
apply clarify
apply(frule subcls1D)
apply(fastforce dest:all_fields_in_has_fields)
apply simp
apply(blast dest:subcls1I trancl_into_trancl)
done
lemma has_fields_mono_lem:
assumes sub: "P ⊢ D ≼⇧* C"
shows "P ⊢ C has_fields FDTs
⟹ ∃pre. P ⊢ D has_fields pre@FDTs ∧ dom(map_of pre) ∩ dom(map_of FDTs) = {}"
using sub apply(induct rule:converse_rtrancl_induct)
apply(rule_tac x = "[]" in exI)
apply simp
apply clarsimp
apply(rename_tac D' D pre)
apply(subgoal_tac "(D',C) : (subcls1 P)^+")
prefer 2 apply(erule (1) rtrancl_into_trancl2)
apply(drule subcls1D)
apply clarsimp
apply(rename_tac fs ms)
apply(drule (2) has_fields_rec)
apply(rule refl)
apply(rule_tac x = "map (λ(F,T). ((F,D'),T)) fs @ pre" in exI)
apply simp
apply(simp add:Int_Un_distrib2)
apply(rule equals0I)
apply(auto dest: subcls_notin_has_fields simp:dom_map_of_conv_image_fst image_def)
done
definition has_field :: "'m prog ⇒ cname ⇒ vname ⇒ ty ⇒ cname ⇒ bool"
("_ ⊢ _ has _:_ in _" [51,51,51,51,51] 50)
where
"P ⊢ C has F:T in D ≡
∃FDTs. P ⊢ C has_fields FDTs ∧ map_of FDTs (F,D) = Some T"
lemma has_field_mono:
"⟦ P ⊢ C has F:T in D; P ⊢ C' ≼⇧* C ⟧ ⟹ P ⊢ C' has F:T in D"
apply(clarsimp simp:has_field_def)
apply(drule (1) has_fields_mono_lem)
apply(fastforce simp: map_add_def split:option.splits)
done
definition sees_field :: "'m prog ⇒ cname ⇒ vname ⇒ ty ⇒ cname ⇒ bool"
("_ ⊢ _ sees _:_ in _" [51,51,51,51,51] 50)
where
"P ⊢ C sees F:T in D ≡
∃FDTs. P ⊢ C has_fields FDTs ∧
map_of (map (λ((F,D),T). (F,(D,T))) FDTs) F = Some(D,T)"
lemma map_of_remap_SomeD:
"map_of (map (λ((k,k'),x). (k,(k',x))) t) k = Some (k',x) ⟹ map_of t (k, k') = Some x"
by (induct t) (auto simp:fun_upd_apply split: if_split_asm)
lemma has_visible_field:
"P ⊢ C sees F:T in D ⟹ P ⊢ C has F:T in D"
by(auto simp add:has_field_def sees_field_def map_of_remap_SomeD)
lemma sees_field_fun:
"⟦P ⊢ C sees F:T in D; P ⊢ C sees F:T' in D'⟧ ⟹ T' = T ∧ D' = D"
by(fastforce simp:sees_field_def dest:has_fields_fun)
lemma sees_field_decl_above:
"P ⊢ C sees F:T in D ⟹ P ⊢ C ≼⇧* D"
apply(auto simp:sees_field_def)
apply(blast intro: has_fields_decl_above map_of_SomeD map_of_remap_SomeD)
done
lemma sees_field_idemp:
"P ⊢ C sees F:T in D ⟹ P ⊢ D sees F:T in D"
apply (unfold sees_field_def)
apply clarsimp
apply (rule_tac P = "map_of xs F = y" for xs y in mp)
prefer 2
apply assumption
apply (thin_tac "map_of xs F = y" for xs y)
apply (erule Fields.induct)
apply clarsimp
apply (frule map_of_SomeD)
apply clarsimp
apply (fastforce intro: has_fields_rec)
apply clarsimp
apply (frule map_of_SomeD)
apply clarsimp
apply (fastforce intro: has_fields_Object)
done
subsection "Functional lookup"
definition "method" :: "'m prog ⇒ cname ⇒ mname ⇒ cname × ty list × ty × 'm"
where
"method P C M ≡ THE (D,Ts,T,m). P ⊢ C sees M:Ts → T = m in D"
definition field :: "'m prog ⇒ cname ⇒ vname ⇒ cname × ty"
where
"field P C F ≡ THE (D,T). P ⊢ C sees F:T in D"
definition fields :: "'m prog ⇒ cname ⇒ ((vname × cname) × ty) list"
where
"fields P C ≡ THE FDTs. P ⊢ C has_fields FDTs"
lemma fields_def2 [simp]: "P ⊢ C has_fields FDTs ⟹ fields P C = FDTs"
by (unfold fields_def) (auto dest: has_fields_fun)
lemma field_def2 [simp]: "P ⊢ C sees F:T in D ⟹ field P C F = (D,T)"
by (unfold field_def) (auto dest: sees_field_fun)
lemma method_def2 [simp]: "P ⊢ C sees M: Ts→T = m in D ⟹ method P C M = (D,Ts,T,m)"
by (unfold method_def) (auto dest: sees_method_fun)
subsection "Code generator setup"
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool)
subcls1p
.
declare subcls1_def [code_pred_def]
code_pred
(modes: i ⇒ i × o ⇒ bool, i ⇒ i × i ⇒ bool)
[inductify]
subcls1
.
definition subcls' where "subcls' G = (subcls1p G)^**"
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool, i ⇒ i ⇒ o ⇒ bool)
[inductify]
subcls'
.
lemma subcls_conv_subcls' [code_unfold]:
"(subcls1 G)^* = {(C, D). subcls' G C D}"
by (simp add: subcls'_def subcls1_def rtrancl_def)
code_pred
(modes: i ⇒ i ⇒ i ⇒ bool)
widen
.
code_pred
(modes: i ⇒ i ⇒ o ⇒ bool)
Fields
.
lemma has_field_code [code_pred_intro]:
"⟦ P ⊢ C has_fields FDTs; map_of FDTs (F, D) = ⌊T⌋ ⟧
⟹ P ⊢ C has F:T in D"
by(auto simp add: has_field_def)
code_pred
(modes: i ⇒ i ⇒ i ⇒ o ⇒ i ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
has_field
by(auto simp add: has_field_def)
lemma sees_field_code [code_pred_intro]:
"⟦ P ⊢ C has_fields FDTs; map_of (map (λ((F, D), T). (F, D, T)) FDTs) F = ⌊(D, T)⌋ ⟧
⟹ P ⊢ C sees F:T in D"
by(auto simp add: sees_field_def)
code_pred
(modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ o ⇒ i ⇒ bool,
i ⇒ i ⇒ i ⇒ i ⇒ o ⇒ bool, i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
sees_field
by(auto simp add: sees_field_def)
code_pred
(modes: i ⇒ i ⇒ o ⇒ bool)
Methods
.
lemma Method_code [code_pred_intro]:
"⟦ P ⊢ C sees_methods Mm; Mm M = ⌊((Ts, T, m), D)⌋ ⟧
⟹ P ⊢ C sees M: Ts→T = m in D"
by(auto simp add: Method_def)
code_pred
(modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ o ⇒ o ⇒ bool,
i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ i ⇒ bool)
Method
by(auto simp add: Method_def)
lemma eval_Method_i_i_i_o_o_o_o_conv:
"Predicate.eval (Method_i_i_i_o_o_o_o P C M) = (λ(Ts, T, m, D). P ⊢ C sees M:Ts→T=m in D)"
by(auto intro: Method_i_i_i_o_o_o_oI elim: Method_i_i_i_o_o_o_oE intro!: ext)
lemma method_code [code]:
"method P C M =
Predicate.the (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (λ(Ts, T, m, D). Predicate.single (D, Ts, T, m)))"
apply (rule sym, rule the_eqI)
apply (simp add: method_def eval_Method_i_i_i_o_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done
lemma eval_Fields_conv:
"Predicate.eval (Fields_i_i_o P C) = (λFDTs. P ⊢ C has_fields FDTs)"
by(auto intro: Fields_i_i_oI elim: Fields_i_i_oE intro!: ext)
lemma fields_code [code]:
"fields P C = Predicate.the (Fields_i_i_o P C)"
by(simp add: fields_def Predicate.the_def eval_Fields_conv)
lemma eval_sees_field_i_i_i_o_o_conv:
"Predicate.eval (sees_field_i_i_i_o_o P C F) = (λ(T, D). P ⊢ C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_oI elim: sees_field_i_i_i_o_oE)
lemma eval_sees_field_i_i_i_o_i_conv:
"Predicate.eval (sees_field_i_i_i_o_i P C F D) = (λT. P ⊢ C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_iI elim: sees_field_i_i_i_o_iE)
lemma field_code [code]:
"field P C F = Predicate.the (Predicate.bind (sees_field_i_i_i_o_o P C F) (λ(T, D). Predicate.single (D, T)))"
apply (rule sym, rule the_eqI)
apply (simp add: field_def eval_sees_field_i_i_i_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done
end
Theory Value
section ‹Jinja Values›
theory Value imports TypeRel begin
type_synonym addr = nat
datatype val
= Unit
| Null
| Bool bool
| Intg int
| Addr addr
primrec the_Intg :: "val ⇒ int" where
"the_Intg (Intg i) = i"
primrec the_Addr :: "val ⇒ addr" where
"the_Addr (Addr a) = a"
primrec default_val :: "ty ⇒ val" where
"default_val Void = Unit"
| "default_val Boolean = Bool False"
| "default_val Integer = Intg 0"
| "default_val NT = Null"
| "default_val (Class C) = Null"
end
Theory Objects
section ‹Objects and the Heap›
theory Objects imports TypeRel Value begin
subsection‹Objects›
type_synonym
fields = "vname × cname ⇀ val"
type_synonym
obj = "cname × fields"
definition obj_ty :: "obj ⇒ ty"
where
"obj_ty obj ≡ Class (fst obj)"
definition init_fields :: "((vname × cname) × ty) list ⇒ fields"
where
"init_fields ≡ map_of ∘ map (λ(F,T). (F,default_val T))"
definition blank :: "'m prog ⇒ cname ⇒ obj"
where
"blank P C ≡ (C,init_fields (fields P C))"
lemma [simp]: "obj_ty (C,fs) = Class C"
by (simp add: obj_ty_def)
subsection‹Heap›
type_synonym heap = "addr ⇀ obj"
abbreviation
cname_of :: "heap ⇒ addr ⇒ cname" where
"cname_of hp a == fst (the (hp a))"
definition new_Addr :: "heap ⇒ addr option"
where
"new_Addr h ≡ if ∃a. h a = None then Some(LEAST a. h a = None) else None"
definition cast_ok :: "'m prog ⇒ cname ⇒ heap ⇒ val ⇒ bool"
where
"cast_ok P C h v ≡ v = Null ∨ P ⊢ cname_of h (the_Addr v) ≼⇧* C"
definition hext :: "heap ⇒ heap ⇒ bool" ("_ ⊴ _" [51,51] 50)
where
"h ⊴ h' ≡ ∀a C fs. h a = Some(C,fs) ⟶ (∃fs'. h' a = Some(C,fs'))"
primrec typeof_h :: "heap ⇒ val ⇒ ty option" ("typeof⇘_⇙")
where
"typeof⇘h⇙ Unit = Some Void"
| "typeof⇘h⇙ Null = Some NT"
| "typeof⇘h⇙ (Bool b) = Some Boolean"
| "typeof⇘h⇙ (Intg i) = Some Integer"
| "typeof⇘h⇙ (Addr a) = (case h a of None ⇒ None | Some(C,fs) ⇒ Some(Class C))"
lemma new_Addr_SomeD:
"new_Addr h = Some a ⟹ h a = None"
by(fastforce simp add:new_Addr_def split:if_splits intro:LeastI)
lemma [simp]: "(typeof⇘h⇙ v = Some Boolean) = (∃b. v = Bool b)"
by(induct v) auto
lemma [simp]: "(typeof⇘h⇙ v = Some Integer) = (∃i. v = Intg i)"
by(cases v) auto
lemma [simp]: "(typeof⇘h⇙ v = Some NT) = (v = Null)"
by(cases v) auto
lemma [simp]: "(typeof⇘h⇙ v = Some(Class C)) = (∃a fs. v = Addr a ∧ h a = Some(C,fs))"
by(cases v) auto
lemma [simp]: "h a = Some(C,fs) ⟹ typeof⇘(h(a↦(C,fs')))⇙ v = typeof⇘h⇙ v"
by(induct v) (auto simp:fun_upd_apply)
text‹For literal values the first parameter of @{term typeof} can be
set to @{term Map.empty} because they do not contain addresses:›
abbreviation
typeof :: "val ⇒ ty option" where
"typeof v == typeof_h Map.empty v"
lemma typeof_lit_typeof:
"typeof v = Some T ⟹ typeof⇘h⇙ v = Some T"
by(cases v) auto
lemma typeof_lit_is_type:
"typeof v = Some T ⟹ is_type P T"
by (induct v) (auto simp:is_type_def)
subsection ‹Heap extension ‹⊴››
lemma hextI: "∀a C fs. h a = Some(C,fs) ⟶ (∃fs'. h' a = Some(C,fs')) ⟹ h ⊴ h'"
apply (unfold hext_def)
apply auto
done
lemma hext_objD: "⟦ h ⊴ h'; h a = Some(C,fs) ⟧ ⟹ ∃fs'. h' a = Some(C,fs')"
apply (unfold hext_def)
apply (force)
done
lemma hext_refl [iff]: "h ⊴ h"
apply (rule hextI)
apply (fast)
done
lemma hext_new [simp]: "h a = None ⟹ h ⊴ h(a↦x)"
apply (rule hextI)
apply (auto simp:fun_upd_apply)
done
lemma hext_trans: "⟦ h ⊴ h'; h' ⊴ h'' ⟧ ⟹ h ⊴ h''"
apply (rule hextI)
apply (fast dest: hext_objD)
done
lemma hext_upd_obj: "h a = Some (C,fs) ⟹ h ⊴ h(a↦(C,fs'))"
apply (rule hextI)
apply (auto simp:fun_upd_apply)
done
lemma hext_typeof_mono: "⟦ h ⊴ h'; typeof⇘h⇙ v = Some T ⟧ ⟹ typeof⇘h'⇙ v = Some T"
apply(cases v)
apply simp
apply simp
apply simp
apply simp
apply(fastforce simp:hext_def)
done
text ‹Code generator setup for @{term "new_Addr"}›
definition gen_new_Addr :: "heap ⇒ addr ⇒ addr option"
where "gen_new_Addr h n ≡ if ∃a. a ≥ n ∧ h a = None then Some(LEAST a. a ≥ n ∧ h a = None) else None"
lemma new_Addr_code_code [code]:
"new_Addr h = gen_new_Addr h 0"
by(simp add: new_Addr_def gen_new_Addr_def split del: if_split cong: if_cong)
lemma gen_new_Addr_code [code]:
"gen_new_Addr h n = (if h n = None then Some n else gen_new_Addr h (Suc n))"
apply(simp add: gen_new_Addr_def)
apply(rule impI)
apply(rule conjI)
apply safe[1]
apply(fastforce intro: Least_equality)
apply(rule arg_cong[where f=Least])
apply(rule ext)
apply(case_tac "n = ac")
apply simp
apply(auto)[1]
apply clarify
apply(subgoal_tac "a = n")
apply simp
apply(rule Least_equality)
apply auto[2]
apply(rule ccontr)
apply(erule_tac x="a" in allE)
apply simp
done
end
Theory Exceptions
section ‹Exceptions›
theory Exceptions imports Objects begin
definition NullPointer :: cname
where
"NullPointer ≡ ''NullPointer''"
definition ClassCast :: cname
where
"ClassCast ≡ ''ClassCast''"
definition OutOfMemory :: cname
where
"OutOfMemory ≡ ''OutOfMemory''"
definition sys_xcpts :: "cname set"
where
"sys_xcpts ≡ {NullPointer, ClassCast, OutOfMemory}"
definition addr_of_sys_xcpt :: "cname ⇒ addr"
where
"addr_of_sys_xcpt s ≡ if s = NullPointer then 0 else
if s = ClassCast then 1 else
if s = OutOfMemory then 2 else undefined"
definition start_heap :: "'c prog ⇒ heap"
where
"start_heap G ≡ Map.empty (addr_of_sys_xcpt NullPointer ↦ blank G NullPointer)
(addr_of_sys_xcpt ClassCast ↦ blank G ClassCast)
(addr_of_sys_xcpt OutOfMemory ↦ blank G OutOfMemory)"
definition preallocated :: "heap ⇒ bool"
where
"preallocated h ≡ ∀C ∈ sys_xcpts. ∃fs. h(addr_of_sys_xcpt C) = Some (C,fs)"
subsection "System exceptions"
lemma [simp]: "NullPointer ∈ sys_xcpts ∧ OutOfMemory ∈ sys_xcpts ∧ ClassCast ∈ sys_xcpts"
by(simp add: sys_xcpts_def)
lemma sys_xcpts_cases [consumes 1, cases set]:
"⟦ C ∈ sys_xcpts; P NullPointer; P OutOfMemory; P ClassCast⟧ ⟹ P C"
by (auto simp add: sys_xcpts_def)
subsection "@{term preallocated}"
lemma preallocated_dom [simp]:
"⟦ preallocated h; C ∈ sys_xcpts ⟧ ⟹ addr_of_sys_xcpt C ∈ dom h"
by (fastforce simp:preallocated_def dom_def)
lemma preallocatedD:
"⟦ preallocated h; C ∈ sys_xcpts ⟧ ⟹ ∃fs. h(addr_of_sys_xcpt C) = Some (C, fs)"
by(auto simp add: preallocated_def sys_xcpts_def)
lemma preallocatedE [elim?]:
"⟦ preallocated h; C ∈ sys_xcpts; ⋀fs. h(addr_of_sys_xcpt C) = Some(C,fs) ⟹ P h C⟧
⟹ P h C"
by (fast dest: preallocatedD)
lemma cname_of_xcp [simp]:
"⟦ preallocated h; C ∈ sys_xcpts ⟧ ⟹ cname_of h (addr_of_sys_xcpt C) = C"
by (auto elim: preallocatedE)
lemma typeof_ClassCast [simp]:
"preallocated h ⟹ typeof⇘h⇙ (Addr(addr_of_sys_xcpt ClassCast)) = Some(Class ClassCast)"
by (auto elim: preallocatedE)
lemma typeof_OutOfMemory [simp]:
"preallocated h ⟹ typeof⇘h⇙ (Addr(addr_of_sys_xcpt OutOfMemory)) = Some(Class OutOfMemory)"
by (auto elim: preallocatedE)
lemma typeof_NullPointer [simp]:
"preallocated h ⟹ typeof⇘h⇙ (Addr(addr_of_sys_xcpt NullPointer)) = Some(Class NullPointer)"
by (auto elim: preallocatedE)
lemma preallocated_hext:
"⟦ preallocated h; h ⊴ h' ⟧ ⟹ preallocated h'"
by (simp add: preallocated_def hext_def)
lemmas preallocated_upd_obj = preallocated_hext [OF _ hext_upd_obj]
lemmas preallocated_new = preallocated_hext [OF _ hext_new]
lemma preallocated_start:
"preallocated (start_heap P)"
by (auto simp add: start_heap_def blank_def sys_xcpts_def fun_upd_apply
addr_of_sys_xcpt_def preallocated_def)
end
Theory Expr
section ‹Expressions›
theory Expr
imports "../Common/Exceptions"
begin
datatype bop = Eq | Add
datatype 'a exp
= new cname
| Cast cname "('a exp)"
| Val val
| BinOp "('a exp)" bop "('a exp)" ("_ «_» _" [80,0,81] 80)
| Var 'a
| LAss 'a "('a exp)" ("_:=_" [90,90]90)
| FAcc "('a exp)" vname cname ("_∙_{_}" [10,90,99]90)
| FAss "('a exp)" vname cname "('a exp)" ("_∙_{_} := _" [10,90,99,90]90)
| Call "('a exp)" mname "('a exp list)" ("_∙_'(_')" [90,99,0] 90)
| Block 'a ty "('a exp)" ("'{_:_; _}")
| Seq "('a exp)" "('a exp)" ("_;;/ _" [61,60]60)
| Cond "('a exp)" "('a exp)" "('a exp)" ("if '(_') _/ else _" [80,79,79]70)
| While "('a exp)" "('a exp)" ("while '(_') _" [80,79]70)
| throw "('a exp)"
| TryCatch "('a exp)" cname 'a "('a exp)" ("try _/ catch'(_ _') _" [0,99,80,79] 70)
type_synonym
expr = "vname exp"
type_synonym
J_mb = "vname list × expr"
type_synonym
J_prog = "J_mb prog"
text‹The semantics of binary operators:›
fun binop :: "bop × val × val ⇒ val option" where
"binop(Eq,v⇩1,v⇩2) = Some(Bool (v⇩1 = v⇩2))"
| "binop(Add,Intg i⇩1,Intg i⇩2) = Some(Intg(i⇩1+i⇩2))"
| "binop(bop,v⇩1,v⇩2) = None"
lemma [simp]:
"(binop(Add,v⇩1,v⇩2) = Some v) = (∃i⇩1 i⇩2. v⇩1 = Intg i⇩1 ∧ v⇩2 = Intg i⇩2 ∧ v = Intg(i⇩1+i⇩2))"
apply(cases v⇩1)
apply auto
apply(cases v⇩2)
apply auto
done
subsection "Syntactic sugar"
abbreviation (input)
InitBlock:: "'a ⇒ ty ⇒ 'a exp ⇒ 'a exp ⇒ 'a exp" ("(1'{_:_ := _;/ _})") where
"InitBlock V T e1 e2 == {V:T; V := e1;; e2}"
abbreviation unit where "unit == Val Unit"
abbreviation null where "null == Val Null"
abbreviation "addr a == Val(Addr a)"
abbreviation "true == Val(Bool True)"
abbreviation "false == Val(Bool False)"
abbreviation
Throw :: "addr ⇒ 'a exp" where
"Throw a == throw(Val(Addr a))"
abbreviation
THROW :: "cname ⇒ 'a exp" where
"THROW xc == Throw(addr_of_sys_xcpt xc)"
subsection‹Free Variables›
primrec fv :: "expr ⇒ vname set" and fvs :: "expr list ⇒ vname set" where
"fv(new C) = {}"
| "fv(Cast C e) = fv e"
| "fv(Val v) = {}"
| "fv(e⇩1 «bop» e⇩2) = fv e⇩1 ∪ fv e⇩2"
| "fv(Var V) = {V}"
| "fv(LAss V e) = {V} ∪ fv e"
| "fv(e∙F{D}) = fv e"
| "fv(e⇩1∙F{D}:=e⇩2) = fv e⇩1 ∪ fv e⇩2"
| "fv(e∙M(es)) = fv e ∪ fvs es"
| "fv({V:T; e}) = fv e - {V}"
| "fv(e⇩1;;e⇩2) = fv e⇩1 ∪ fv e⇩2"
| "fv(if (b) e⇩1 else e⇩2) = fv b ∪ fv e⇩1 ∪ fv e⇩2"
| "fv(while (b) e) = fv b ∪ fv e"
| "fv(throw e) = fv e"
| "fv(try e⇩1 catch(C V) e⇩2) = fv e⇩1 ∪ (fv e⇩2 - {V})"
| "fvs([]) = {}"
| "fvs(e#es) = fv e ∪ fvs es"
lemma [simp]: "fvs(es⇩1 @ es⇩2) = fvs es⇩1 ∪ fvs es⇩2"
by (induct es⇩1 type:list) auto
lemma [simp]: "fvs(map Val vs) = {}"
by (induct vs) auto
end
Theory State
section ‹Program State›
theory State imports "../Common/Exceptions" begin
type_synonym
locals = "vname ⇀ val"
type_synonym
state = "heap × locals"
definition hp :: "state ⇒ heap"
where
"hp ≡ fst"
definition lcl :: "state ⇒ locals"
where
"lcl ≡ snd"
declare hp_def[simp] lcl_def[simp]
end
Theory BigStep
section ‹Big Step Semantics›
theory BigStep imports Expr State begin
inductive
eval :: "J_prog ⇒ expr ⇒ state ⇒ expr ⇒ state ⇒ bool"
("_ ⊢ ((1⟨_,/_⟩) ⇒/ (1⟨_,/_⟩))" [51,0,0,0,0] 81)
and evals :: "J_prog ⇒ expr list ⇒ state ⇒ expr list ⇒ state ⇒ bool"
("_ ⊢ ((1⟨_,/_⟩) [⇒]/ (1⟨_,/_⟩))" [51,0,0,0,0] 81)
for P :: J_prog
where
New:
"⟦ new_Addr h = Some a; P ⊢ C has_fields FDTs; h' = h(a↦(C,init_fields FDTs)) ⟧
⟹ P ⊢ ⟨new C,(h,l)⟩ ⇒ ⟨addr a,(h',l)⟩"
| NewFail:
"new_Addr h = None ⟹
P ⊢ ⟨new C, (h,l)⟩ ⇒ ⟨THROW OutOfMemory,(h,l)⟩"
| Cast:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨addr a,(h,l)⟩; h a = Some(D,fs); P ⊢ D ≼⇧* C ⟧
⟹ P ⊢ ⟨Cast C e,s⇩0⟩ ⇒ ⟨addr a,(h,l)⟩"
| CastNull:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩ ⟹
P ⊢ ⟨Cast C e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩"
| CastFail:
"⟦ P ⊢ ⟨e,s⇩0⟩⇒ ⟨addr a,(h,l)⟩; h a = Some(D,fs); ¬ P ⊢ D ≼⇧* C ⟧
⟹ P ⊢ ⟨Cast C e,s⇩0⟩ ⇒ ⟨THROW ClassCast,(h,l)⟩"
| CastThrow:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢ ⟨Cast C e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| Val:
"P ⊢ ⟨Val v,s⟩ ⇒ ⟨Val v,s⟩"
| BinOp:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨Val v⇩1,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ ⇒ ⟨Val v⇩2,s⇩2⟩; binop(bop,v⇩1,v⇩2) = Some v ⟧
⟹ P ⊢ ⟨e⇩1 «bop» e⇩2,s⇩0⟩⇒⟨Val v,s⇩2⟩"
| BinOpThrow1:
"P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨throw e,s⇩1⟩ ⟹
P ⊢ ⟨e⇩1 «bop» e⇩2, s⇩0⟩ ⇒ ⟨throw e,s⇩1⟩"
| BinOpThrow2:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨Val v⇩1,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ ⇒ ⟨throw e,s⇩2⟩ ⟧
⟹ P ⊢ ⟨e⇩1 «bop» e⇩2,s⇩0⟩ ⇒ ⟨throw e,s⇩2⟩"
| Var:
"l V = Some v ⟹
P ⊢ ⟨Var V,(h,l)⟩ ⇒ ⟨Val v,(h,l)⟩"
| LAss:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨Val v,(h,l)⟩; l' = l(V↦v) ⟧
⟹ P ⊢ ⟨V:=e,s⇩0⟩ ⇒ ⟨unit,(h,l')⟩"
| LAssThrow:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢ ⟨V:=e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| FAcc:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨addr a,(h,l)⟩; h a = Some(C,fs); fs(F,D) = Some v ⟧
⟹ P ⊢ ⟨e∙F{D},s⇩0⟩ ⇒ ⟨Val v,(h,l)⟩"
| FAccNull:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩ ⟹
P ⊢ ⟨e∙F{D},s⇩0⟩ ⇒ ⟨THROW NullPointer,s⇩1⟩"
| FAccThrow:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢ ⟨e∙F{D},s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| FAss:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨addr a,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ ⇒ ⟨Val v,(h⇩2,l⇩2)⟩;
h⇩2 a = Some(C,fs); fs' = fs((F,D)↦v); h⇩2' = h⇩2(a↦(C,fs')) ⟧
⟹ P ⊢ ⟨e⇩1∙F{D}:=e⇩2,s⇩0⟩ ⇒ ⟨unit,(h⇩2',l⇩2)⟩"
| FAssNull:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨null,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ ⇒ ⟨Val v,s⇩2⟩ ⟧ ⟹
P ⊢ ⟨e⇩1∙F{D}:=e⇩2,s⇩0⟩ ⇒ ⟨THROW NullPointer,s⇩2⟩"
| FAssThrow1:
"P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢ ⟨e⇩1∙F{D}:=e⇩2,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| FAssThrow2:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨Val v,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ ⇒ ⟨throw e',s⇩2⟩ ⟧
⟹ P ⊢ ⟨e⇩1∙F{D}:=e⇩2,s⇩0⟩ ⇒ ⟨throw e',s⇩2⟩"
| CallObjThrow:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢ ⟨e∙M(ps),s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| CallParamsThrow:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨Val v,s⇩1⟩; P ⊢ ⟨es,s⇩1⟩ [⇒] ⟨map Val vs @ throw ex # es',s⇩2⟩ ⟧
⟹ P ⊢ ⟨e∙M(es),s⇩0⟩ ⇒ ⟨throw ex,s⇩2⟩"
| CallNull:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩; P ⊢ ⟨ps,s⇩1⟩ [⇒] ⟨map Val vs,s⇩2⟩ ⟧
⟹ P ⊢ ⟨e∙M(ps),s⇩0⟩ ⇒ ⟨THROW NullPointer,s⇩2⟩"
| Call:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨addr a,s⇩1⟩; P ⊢ ⟨ps,s⇩1⟩ [⇒] ⟨map Val vs,(h⇩2,l⇩2)⟩;
h⇩2 a = Some(C,fs); P ⊢ C sees M:Ts→T = (pns,body) in D;
length vs = length pns; l⇩2' = [this↦Addr a, pns[↦]vs];
P ⊢ ⟨body,(h⇩2,l⇩2')⟩ ⇒ ⟨e',(h⇩3,l⇩3)⟩ ⟧
⟹ P ⊢ ⟨e∙M(ps),s⇩0⟩ ⇒ ⟨e',(h⇩3,l⇩2)⟩"
| Block:
"P ⊢ ⟨e⇩0,(h⇩0,l⇩0(V:=None))⟩ ⇒ ⟨e⇩1,(h⇩1,l⇩1)⟩ ⟹
P ⊢ ⟨{V:T; e⇩0},(h⇩0,l⇩0)⟩ ⇒ ⟨e⇩1,(h⇩1,l⇩1(V:=l⇩0 V))⟩"
| Seq:
"⟦ P ⊢ ⟨e⇩0,s⇩0⟩ ⇒ ⟨Val v,s⇩1⟩; P ⊢ ⟨e⇩1,s⇩1⟩ ⇒ ⟨e⇩2,s⇩2⟩ ⟧
⟹ P ⊢ ⟨e⇩0;;e⇩1,s⇩0⟩ ⇒ ⟨e⇩2,s⇩2⟩"
| SeqThrow:
"P ⊢ ⟨e⇩0,s⇩0⟩ ⇒ ⟨throw e,s⇩1⟩ ⟹
P ⊢ ⟨e⇩0;;e⇩1,s⇩0⟩⇒⟨throw e,s⇩1⟩"
| CondT:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨true,s⇩1⟩; P ⊢ ⟨e⇩1,s⇩1⟩ ⇒ ⟨e',s⇩2⟩ ⟧
⟹ P ⊢ ⟨if (e) e⇩1 else e⇩2,s⇩0⟩ ⇒ ⟨e',s⇩2⟩"
| CondF:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨false,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ ⇒ ⟨e',s⇩2⟩ ⟧
⟹ P ⊢ ⟨if (e) e⇩1 else e⇩2,s⇩0⟩ ⇒ ⟨e',s⇩2⟩"
| CondThrow:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢ ⟨if (e) e⇩1 else e⇩2, s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| WhileF:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨false,s⇩1⟩ ⟹
P ⊢ ⟨while (e) c,s⇩0⟩ ⇒ ⟨unit,s⇩1⟩"
| WhileT:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨true,s⇩1⟩; P ⊢ ⟨c,s⇩1⟩ ⇒ ⟨Val v⇩1,s⇩2⟩; P ⊢ ⟨while (e) c,s⇩2⟩ ⇒ ⟨e⇩3,s⇩3⟩ ⟧
⟹ P ⊢ ⟨while (e) c,s⇩0⟩ ⇒ ⟨e⇩3,s⇩3⟩"
| WhileCondThrow:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨ throw e',s⇩1⟩ ⟹
P ⊢ ⟨while (e) c,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| WhileBodyThrow:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨true,s⇩1⟩; P ⊢ ⟨c,s⇩1⟩ ⇒ ⟨throw e',s⇩2⟩⟧
⟹ P ⊢ ⟨while (e) c,s⇩0⟩ ⇒ ⟨throw e',s⇩2⟩"
| Throw:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨addr a,s⇩1⟩ ⟹
P ⊢ ⟨throw e,s⇩0⟩ ⇒ ⟨Throw a,s⇩1⟩"
| ThrowNull:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩ ⟹
P ⊢ ⟨throw e,s⇩0⟩ ⇒ ⟨THROW NullPointer,s⇩1⟩"
| ThrowThrow:
"P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢ ⟨throw e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| Try:
"P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨Val v⇩1,s⇩1⟩ ⟹
P ⊢ ⟨try e⇩1 catch(C V) e⇩2,s⇩0⟩ ⇒ ⟨Val v⇩1,s⇩1⟩"
| TryCatch:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨Throw a,(h⇩1,l⇩1)⟩; h⇩1 a = Some(D,fs); P ⊢ D ≼⇧* C;
P ⊢ ⟨e⇩2,(h⇩1,l⇩1(V↦Addr a))⟩ ⇒ ⟨e⇩2',(h⇩2,l⇩2)⟩ ⟧
⟹ P ⊢ ⟨try e⇩1 catch(C V) e⇩2,s⇩0⟩ ⇒ ⟨e⇩2',(h⇩2,l⇩2(V:=l⇩1 V))⟩"
| TryThrow:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ ⇒ ⟨Throw a,(h⇩1,l⇩1)⟩; h⇩1 a = Some(D,fs); ¬ P ⊢ D ≼⇧* C ⟧
⟹ P ⊢ ⟨try e⇩1 catch(C V) e⇩2,s⇩0⟩ ⇒ ⟨Throw a,(h⇩1,l⇩1)⟩"
| Nil:
"P ⊢ ⟨[],s⟩ [⇒] ⟨[],s⟩"
| Cons:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨Val v,s⇩1⟩; P ⊢ ⟨es,s⇩1⟩ [⇒] ⟨es',s⇩2⟩ ⟧
⟹ P ⊢ ⟨e#es,s⇩0⟩ [⇒] ⟨Val v # es',s⇩2⟩"
| ConsThrow:
"P ⊢ ⟨e, s⇩0⟩ ⇒ ⟨throw e', s⇩1⟩ ⟹
P ⊢ ⟨e#es, s⇩0⟩ [⇒] ⟨throw e' # es, s⇩1⟩"
lemmas eval_evals_induct = eval_evals.induct [split_format (complete)]
and eval_evals_inducts = eval_evals.inducts [split_format (complete)]
inductive_cases eval_cases [cases set]:
"P ⊢ ⟨Cast C e,s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨Val v,s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨e⇩1 «bop» e⇩2,s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨V:=e,s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨e∙F{D},s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨e⇩1∙F{D}:=e⇩2,s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨e∙M{D}(es),s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨{V:T;e⇩1},s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨e⇩1;;e⇩2,s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨if (e) e⇩1 else e⇩2,s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨while (b) c,s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨throw e,s⟩ ⇒ ⟨e',s'⟩"
"P ⊢ ⟨try e⇩1 catch(C V) e⇩2,s⟩ ⇒ ⟨e',s'⟩"
inductive_cases evals_cases [cases set]:
"P ⊢ ⟨[],s⟩ [⇒] ⟨e',s'⟩"
"P ⊢ ⟨e#es,s⟩ [⇒] ⟨e',s'⟩"
subsection"Final expressions"
definition final :: "'a exp ⇒ bool"
where
"final e ≡ (∃v. e = Val v) ∨ (∃a. e = Throw a)"
definition finals:: "'a exp list ⇒ bool"
where
"finals es ≡ (∃vs. es = map Val vs) ∨ (∃vs a es'. es = map Val vs @ Throw a # es')"
lemma [simp]: "final(Val v)"
by(simp add:final_def)
lemma [simp]: "final(throw e) = (∃a. e = addr a)"
by(simp add:final_def)
lemma finalE: "⟦ final e; ⋀v. e = Val v ⟹ R; ⋀a. e = Throw a ⟹ R ⟧ ⟹ R"
by(auto simp:final_def)
lemma [iff]: "finals []"
by(simp add:finals_def)
lemma [iff]: "finals (Val v # es) = finals es"
apply(clarsimp simp add: finals_def)
apply(rule iffI)
apply(erule disjE)
apply simp
apply(rule disjI2)
apply clarsimp
apply(case_tac vs)
apply simp
apply fastforce
apply(erule disjE)
apply clarsimp
apply(rule disjI2)
apply clarsimp
apply(rule_tac x = "v#vs" in exI)
apply simp
done
lemma finals_app_map[iff]: "finals (map Val vs @ es) = finals es"
by(induct_tac vs, auto)
lemma [iff]: "finals (map Val vs)"
using finals_app_map[of vs "[]"]by(simp)
lemma [iff]: "finals (throw e # es) = (∃a. e = addr a)"
apply(simp add:finals_def)
apply(rule iffI)
apply clarsimp
apply(case_tac vs)
apply simp
apply fastforce
apply clarsimp
apply(rule_tac x = "[]" in exI)
apply simp
done
lemma not_finals_ConsI: "¬ final e ⟹ ¬ finals(e#es)"
apply(clarsimp simp add:finals_def final_def)
apply(case_tac vs)
apply auto
done
lemma eval_final: "P ⊢ ⟨e,s⟩ ⇒ ⟨e',s'⟩ ⟹ final e'"
and evals_final: "P ⊢ ⟨es,s⟩ [⇒] ⟨es',s'⟩ ⟹ finals es'"
by(induct rule:eval_evals.inducts, simp_all)
lemma eval_lcl_incr: "P ⊢ ⟨e,(h⇩0,l⇩0)⟩ ⇒ ⟨e',(h⇩1,l⇩1)⟩ ⟹ dom l⇩0 ⊆ dom l⇩1"
and evals_lcl_incr: "P ⊢ ⟨es,(h⇩0,l⇩0)⟩ [⇒] ⟨es',(h⇩1,l⇩1)⟩ ⟹ dom l⇩0 ⊆ dom l⇩1"
proof (induct rule: eval_evals_inducts)
case BinOp show ?case by(rule subset_trans)(rule BinOp.hyps)+
next
case Call thus ?case
by(simp del: fun_upd_apply)
next
case Seq show ?case by(rule subset_trans)(rule Seq.hyps)+
next
case CondT show ?case by(rule subset_trans)(rule CondT.hyps)+
next
case CondF show ?case by(rule subset_trans)(rule CondF.hyps)+
next
case WhileT thus ?case by(blast)
next
case TryCatch thus ?case by(clarsimp simp:dom_def split:if_split_asm) blast
next
case Cons show ?case by(rule subset_trans)(rule Cons.hyps)+
next
case Block thus ?case by(auto simp del:fun_upd_apply)
qed auto
text‹Only used later, in the small to big translation, but is already a
good sanity check:›
lemma eval_finalId: "final e ⟹ P ⊢ ⟨e,s⟩ ⇒ ⟨e,s⟩"
by (erule finalE) (iprover intro: eval_evals.intros)+
lemma eval_finalsId:
assumes finals: "finals es" shows "P ⊢ ⟨es,s⟩ [⇒] ⟨es,s⟩"
using finals
proof (induct es type: list)
case Nil show ?case by (rule eval_evals.intros)
next
case (Cons e es)
have hyp: "finals es ⟹ P ⊢ ⟨es,s⟩ [⇒] ⟨es,s⟩"
and finals: "finals (e # es)" by fact+
show "P ⊢ ⟨e # es,s⟩ [⇒] ⟨e # es,s⟩"
proof cases
assume "final e"
thus ?thesis
proof (cases rule: finalE)
fix v assume e: "e = Val v"
have "P ⊢ ⟨Val v,s⟩ ⇒ ⟨Val v,s⟩" by (simp add: eval_finalId)
moreover from finals e have "P ⊢ ⟨es,s⟩ [⇒] ⟨es,s⟩" by(fast intro:hyp)
ultimately have "P ⊢ ⟨Val v#es,s⟩ [⇒] ⟨Val v#es,s⟩"
by (rule eval_evals.intros)
with e show ?thesis by simp
next
fix a assume e: "e = Throw a"
have "P ⊢ ⟨Throw a,s⟩ ⇒ ⟨Throw a,s⟩" by (simp add: eval_finalId)
hence "P ⊢ ⟨Throw a#es,s⟩ [⇒] ⟨Throw a#es,s⟩" by (rule eval_evals.intros)
with e show ?thesis by simp
qed
next
assume "¬ final e"
with not_finals_ConsI finals have False by blast
thus ?thesis ..
qed
qed
theorem eval_hext: "P ⊢ ⟨e,(h,l)⟩ ⇒ ⟨e',(h',l')⟩ ⟹ h ⊴ h'"
and evals_hext: "P ⊢ ⟨es,(h,l)⟩ [⇒] ⟨es',(h',l')⟩ ⟹ h ⊴ h'"
proof (induct rule: eval_evals_inducts)
case New thus ?case
by(fastforce intro!: hext_new intro:LeastI simp:new_Addr_def
split:if_split_asm simp del:fun_upd_apply)
next
case BinOp thus ?case by (fast elim!:hext_trans)
next
case BinOpThrow2 thus ?case by(fast elim!: hext_trans)
next
case FAss thus ?case
by(auto simp:sym[THEN hext_upd_obj] simp del:fun_upd_apply
elim!: hext_trans)
next
case FAssNull thus ?case by (fast elim!:hext_trans)
next
case FAssThrow2 thus ?case by (fast elim!:hext_trans)
next
case CallParamsThrow thus ?case by(fast elim!: hext_trans)
next
case CallNull thus ?case by(fast elim!: hext_trans)
next
case Call thus ?case by(fast elim!: hext_trans)
next
case Seq thus ?case by(fast elim!: hext_trans)
next
case CondT thus ?case by(fast elim!: hext_trans)
next
case CondF thus ?case by(fast elim!: hext_trans)
next
case WhileT thus ?case by(fast elim!: hext_trans)
next
case WhileBodyThrow thus ?case by (fast elim!: hext_trans)
next
case TryCatch thus ?case by(fast elim!: hext_trans)
next
case Cons thus ?case by (fast intro: hext_trans)
qed auto
end
Theory SmallStep
section ‹Small Step Semantics›
theory SmallStep
imports Expr State
begin
fun blocks :: "vname list * ty list * val list * expr ⇒ expr"
where
"blocks(V#Vs, T#Ts, v#vs, e) = {V:T := Val v; blocks(Vs,Ts,vs,e)}"
|"blocks([],[],[],e) = e"
lemmas blocks_induct = blocks.induct[split_format (complete)]
lemma [simp]:
"⟦ size vs = size Vs; size Ts = size Vs ⟧ ⟹ fv(blocks(Vs,Ts,vs,e)) = fv e - set Vs"
by (induct rule:blocks_induct) auto
definition assigned :: "vname ⇒ expr ⇒ bool"
where
"assigned V e ≡ ∃v e'. e = (V := Val v;; e')"
inductive_set
red :: "J_prog ⇒ ((expr × state) × (expr × state)) set"
and reds :: "J_prog ⇒ ((expr list × state) × (expr list × state)) set"
and red' :: "J_prog ⇒ expr ⇒ state ⇒ expr ⇒ state ⇒ bool"
("_ ⊢ ((1⟨_,/_⟩) →/ (1⟨_,/_⟩))" [51,0,0,0,0] 81)
and reds' :: "J_prog ⇒ expr list ⇒ state ⇒ expr list ⇒ state ⇒ bool"
("_ ⊢ ((1⟨_,/_⟩) [→]/ (1⟨_,/_⟩))" [51,0,0,0,0] 81)
for P :: J_prog
where
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ≡ ((e,s), e',s') ∈ red P"
| "P ⊢ ⟨es,s⟩ [→] ⟨es',s'⟩ ≡ ((es,s), es',s') ∈ reds P"
| RedNew:
"⟦ new_Addr h = Some a; P ⊢ C has_fields FDTs; h' = h(a↦(C,init_fields FDTs)) ⟧
⟹ P ⊢ ⟨new C, (h,l)⟩ → ⟨addr a, (h',l)⟩"
| RedNewFail:
"new_Addr h = None ⟹
P ⊢ ⟨new C, (h,l)⟩ → ⟨THROW OutOfMemory, (h,l)⟩"
| CastRed:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨Cast C e, s⟩ → ⟨Cast C e', s'⟩"
| RedCastNull:
"P ⊢ ⟨Cast C null, s⟩ → ⟨null,s⟩"
| RedCast:
"⟦ hp s a = Some(D,fs); P ⊢ D ≼⇧* C ⟧
⟹ P ⊢ ⟨Cast C (addr a), s⟩ → ⟨addr a, s⟩"
| RedCastFail:
"⟦ hp s a = Some(D,fs); ¬ P ⊢ D ≼⇧* C ⟧
⟹ P ⊢ ⟨Cast C (addr a), s⟩ → ⟨THROW ClassCast, s⟩"
| BinOpRed1:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨e «bop» e⇩2, s⟩ → ⟨e' «bop» e⇩2, s'⟩"
| BinOpRed2:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨(Val v⇩1) «bop» e, s⟩ → ⟨(Val v⇩1) «bop» e', s'⟩"
| RedBinOp:
"binop(bop,v⇩1,v⇩2) = Some v ⟹
P ⊢ ⟨(Val v⇩1) «bop» (Val v⇩2), s⟩ → ⟨Val v,s⟩"
| RedVar:
"lcl s V = Some v ⟹
P ⊢ ⟨Var V,s⟩ → ⟨Val v,s⟩"
| LAssRed:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨V:=e,s⟩ → ⟨V:=e',s'⟩"
| RedLAss:
"P ⊢ ⟨V:=(Val v), (h,l)⟩ → ⟨unit, (h,l(V↦v))⟩"
| FAccRed:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨e∙F{D}, s⟩ → ⟨e'∙F{D}, s'⟩"
| RedFAcc:
"⟦ hp s a = Some(C,fs); fs(F,D) = Some v ⟧
⟹ P ⊢ ⟨(addr a)∙F{D}, s⟩ → ⟨Val v,s⟩"
| RedFAccNull:
"P ⊢ ⟨null∙F{D}, s⟩ → ⟨THROW NullPointer, s⟩"
| FAssRed1:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨e∙F{D}:=e⇩2, s⟩ → ⟨e'∙F{D}:=e⇩2, s'⟩"
| FAssRed2:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨Val v∙F{D}:=e, s⟩ → ⟨Val v∙F{D}:=e', s'⟩"
| RedFAss:
"h a = Some(C,fs) ⟹
P ⊢ ⟨(addr a)∙F{D}:=(Val v), (h,l)⟩ → ⟨unit, (h(a ↦ (C,fs((F,D) ↦ v))),l)⟩"
| RedFAssNull:
"P ⊢ ⟨null∙F{D}:=Val v, s⟩ → ⟨THROW NullPointer, s⟩"
| CallObj:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨e∙M(es),s⟩ → ⟨e'∙M(es),s'⟩"
| CallParams:
"P ⊢ ⟨es,s⟩ [→] ⟨es',s'⟩ ⟹
P ⊢ ⟨(Val v)∙M(es),s⟩ → ⟨(Val v)∙M(es'),s'⟩"
| RedCall:
"⟦ hp s a = Some(C,fs); P ⊢ C sees M:Ts→T = (pns,body) in D; size vs = size pns; size Ts = size pns ⟧
⟹ P ⊢ ⟨(addr a)∙M(map Val vs), s⟩ → ⟨blocks(this#pns, Class D#Ts, Addr a#vs, body), s⟩"
| RedCallNull:
"P ⊢ ⟨null∙M(map Val vs),s⟩ → ⟨THROW NullPointer,s⟩"
| BlockRedNone:
"⟦ P ⊢ ⟨e, (h,l(V:=None))⟩ → ⟨e', (h',l')⟩; l' V = None; ¬ assigned V e ⟧
⟹ P ⊢ ⟨{V:T; e}, (h,l)⟩ → ⟨{V:T; e'}, (h',l'(V := l V))⟩"
| BlockRedSome:
"⟦ P ⊢ ⟨e, (h,l(V:=None))⟩ → ⟨e', (h',l')⟩; l' V = Some v;¬ assigned V e ⟧
⟹ P ⊢ ⟨{V:T; e}, (h,l)⟩ → ⟨{V:T := Val v; e'}, (h',l'(V := l V))⟩"
| InitBlockRed:
"⟦ P ⊢ ⟨e, (h,l(V↦v))⟩ → ⟨e', (h',l')⟩; l' V = Some v' ⟧
⟹ P ⊢ ⟨{V:T := Val v; e}, (h,l)⟩ → ⟨{V:T := Val v'; e'}, (h',l'(V := l V))⟩"
| RedBlock:
"P ⊢ ⟨{V:T; Val u}, s⟩ → ⟨Val u, s⟩"
| RedInitBlock:
"P ⊢ ⟨{V:T := Val v; Val u}, s⟩ → ⟨Val u, s⟩"
| SeqRed:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨e;;e⇩2, s⟩ → ⟨e';;e⇩2, s'⟩"
| RedSeq:
"P ⊢ ⟨(Val v);;e⇩2, s⟩ → ⟨e⇩2, s⟩"
| CondRed:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨if (e) e⇩1 else e⇩2, s⟩ → ⟨if (e') e⇩1 else e⇩2, s'⟩"
| RedCondT:
"P ⊢ ⟨if (true) e⇩1 else e⇩2, s⟩ → ⟨e⇩1, s⟩"
| RedCondF:
"P ⊢ ⟨if (false) e⇩1 else e⇩2, s⟩ → ⟨e⇩2, s⟩"
| RedWhile:
"P ⊢ ⟨while(b) c, s⟩ → ⟨if(b) (c;;while(b) c) else unit, s⟩"
| ThrowRed:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨throw e, s⟩ → ⟨throw e', s'⟩"
| RedThrowNull:
"P ⊢ ⟨throw null, s⟩ → ⟨THROW NullPointer, s⟩"
| TryRed:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨try e catch(C V) e⇩2, s⟩ → ⟨try e' catch(C V) e⇩2, s'⟩"
| RedTry:
"P ⊢ ⟨try (Val v) catch(C V) e⇩2, s⟩ → ⟨Val v, s⟩"
| RedTryCatch:
"⟦ hp s a = Some(D,fs); P ⊢ D ≼⇧* C ⟧
⟹ P ⊢ ⟨try (Throw a) catch(C V) e⇩2, s⟩ → ⟨{V:Class C := addr a; e⇩2}, s⟩"
| RedTryFail:
"⟦ hp s a = Some(D,fs); ¬ P ⊢ D ≼⇧* C ⟧
⟹ P ⊢ ⟨try (Throw a) catch(C V) e⇩2, s⟩ → ⟨Throw a, s⟩"
| ListRed1:
"P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹
P ⊢ ⟨e#es,s⟩ [→] ⟨e'#es,s'⟩"
| ListRed2:
"P ⊢ ⟨es,s⟩ [→] ⟨es',s'⟩ ⟹
P ⊢ ⟨Val v # es,s⟩ [→] ⟨Val v # es',s'⟩"
| CastThrow: "P ⊢ ⟨Cast C (throw e), s⟩ → ⟨throw e, s⟩"
| BinOpThrow1: "P ⊢ ⟨(throw e) «bop» e⇩2, s⟩ → ⟨throw e, s⟩"
| BinOpThrow2: "P ⊢ ⟨(Val v⇩1) «bop» (throw e), s⟩ → ⟨throw e, s⟩"
| LAssThrow: "P ⊢ ⟨V:=(throw e), s⟩ → ⟨throw e, s⟩"
| FAccThrow: "P ⊢ ⟨(throw e)∙F{D}, s⟩ → ⟨throw e, s⟩"
| FAssThrow1: "P ⊢ ⟨(throw e)∙F{D}:=e⇩2, s⟩ → ⟨throw e,s⟩"
| FAssThrow2: "P ⊢ ⟨Val v∙F{D}:=(throw e), s⟩ → ⟨throw e, s⟩"
| CallThrowObj: "P ⊢ ⟨(throw e)∙M(es), s⟩ → ⟨throw e, s⟩"
| CallThrowParams: "⟦ es = map Val vs @ throw e # es' ⟧ ⟹ P ⊢ ⟨(Val v)∙M(es), s⟩ → ⟨throw e, s⟩"
| BlockThrow: "P ⊢ ⟨{V:T; Throw a}, s⟩ → ⟨Throw a, s⟩"
| InitBlockThrow: "P ⊢ ⟨{V:T := Val v; Throw a}, s⟩ → ⟨Throw a, s⟩"
| SeqThrow: "P ⊢ ⟨(throw e);;e⇩2, s⟩ → ⟨throw e, s⟩"
| CondThrow: "P ⊢ ⟨if (throw e) e⇩1 else e⇩2, s⟩ → ⟨throw e, s⟩"
| ThrowThrow: "P ⊢ ⟨throw(throw e), s⟩ → ⟨throw e, s⟩"
lemmas red_reds_induct = red_reds.induct [split_format (complete)]
and red_reds_inducts = red_reds.inducts [split_format (complete)]
inductive_cases [elim!]:
"P ⊢ ⟨V:=e,s⟩ → ⟨e',s'⟩"
"P ⊢ ⟨e1;;e2,s⟩ → ⟨e',s'⟩"
subsection‹The reflexive transitive closure›
abbreviation
Step :: "J_prog ⇒ expr ⇒ state ⇒ expr ⇒ state ⇒ bool"
("_ ⊢ ((1⟨_,/_⟩) →*/ (1⟨_,/_⟩))" [51,0,0,0,0] 81)
where "P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ≡ ((e,s), e',s') ∈ (red P)⇧*"
abbreviation
Steps :: "J_prog ⇒ expr list ⇒ state ⇒ expr list ⇒ state ⇒ bool"
("_ ⊢ ((1⟨_,/_⟩) [→]*/ (1⟨_,/_⟩))" [51,0,0,0,0] 81)
where "P ⊢ ⟨es,s⟩ [→]* ⟨es',s'⟩ ≡ ((es,s), es',s') ∈ (reds P)⇧*"
lemma converse_rtrancl_induct_red[consumes 1]:
assumes "P ⊢ ⟨e,(h,l)⟩ →* ⟨e',(h',l')⟩"
and "⋀e h l. R e h l e h l"
and "⋀e⇩0 h⇩0 l⇩0 e⇩1 h⇩1 l⇩1 e' h' l'.
⟦ P ⊢ ⟨e⇩0,(h⇩0,l⇩0)⟩ → ⟨e⇩1,(h⇩1,l⇩1)⟩; R e⇩1 h⇩1 l⇩1 e' h' l' ⟧ ⟹ R e⇩0 h⇩0 l⇩0 e' h' l'"
shows "R e h l e' h' l'"
proof -
{ fix s s'
assume reds: "P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩"
and base: "⋀e s. R e (hp s) (lcl s) e (hp s) (lcl s)"
and red⇩1: "⋀e⇩0 s⇩0 e⇩1 s⇩1 e' s'.
⟦ P ⊢ ⟨e⇩0,s⇩0⟩ → ⟨e⇩1,s⇩1⟩; R e⇩1 (hp s⇩1) (lcl s⇩1) e' (hp s') (lcl s') ⟧
⟹ R e⇩0 (hp s⇩0) (lcl s⇩0) e' (hp s') (lcl s')"
from reds have "R e (hp s) (lcl s) e' (hp s') (lcl s')"
proof (induct rule:converse_rtrancl_induct2)
case refl show ?case by(rule base)
next
case (step e⇩0 s⇩0 e s)
thus ?case by(blast intro:red⇩1)
qed
}
with assms show ?thesis by fastforce
qed
subsection‹Some easy lemmas›
lemma [iff]: "¬ P ⊢ ⟨[],s⟩ [→] ⟨es',s'⟩"
by(blast elim: reds.cases)
lemma [iff]: "¬ P ⊢ ⟨Val v,s⟩ → ⟨e',s'⟩"
by(fastforce elim: red.cases)
lemma [iff]: "¬ P ⊢ ⟨Throw a,s⟩ → ⟨e',s'⟩"
by(fastforce elim: red.cases)
lemma red_hext_incr: "P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩ ⟹ h ⊴ h'"
and reds_hext_incr: "P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩ ⟹ h ⊴ h'"
proof(induct rule:red_reds_inducts)
case RedNew thus ?case
by(fastforce dest:new_Addr_SomeD simp:hext_def split:if_splits)
next
case RedFAss thus ?case by(simp add:hext_def split:if_splits)
qed simp_all
lemma red_lcl_incr: "P ⊢ ⟨e,(h⇩0,l⇩0)⟩ → ⟨e',(h⇩1,l⇩1)⟩ ⟹ dom l⇩0 ⊆ dom l⇩1"
and "P ⊢ ⟨es,(h⇩0,l⇩0)⟩ [→] ⟨es',(h⇩1,l⇩1)⟩ ⟹ dom l⇩0 ⊆ dom l⇩1"
by(induct rule: red_reds_inducts)(auto simp del:fun_upd_apply)
lemma red_lcl_add: "P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩ ⟹ (⋀l⇩0. P ⊢ ⟨e,(h,l⇩0++l)⟩ → ⟨e',(h',l⇩0++l')⟩)"
and "P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩ ⟹ (⋀l⇩0. P ⊢ ⟨es,(h,l⇩0++l)⟩ [→] ⟨es',(h',l⇩0++l')⟩)"
proof (induct rule:red_reds_inducts)
case RedCast thus ?case by(fastforce intro:red_reds.intros)
next
case RedCastFail thus ?case by(force intro:red_reds.intros)
next
case RedFAcc thus ?case by(fastforce intro:red_reds.intros)
next
case RedCall thus ?case by(fastforce intro:red_reds.intros)
next
case (InitBlockRed e h l V v e' h' l' v' T l⇩0)
have IH: "⋀l⇩0. P ⊢ ⟨e,(h, l⇩0 ++ l(V ↦ v))⟩ → ⟨e',(h', l⇩0 ++ l')⟩"
and l'V: "l' V = Some v'" by fact+
from IH have IH': "P ⊢ ⟨e,(h, (l⇩0 ++ l)(V ↦ v))⟩ → ⟨e',(h', l⇩0 ++ l')⟩"
by simp
have "(l⇩0 ++ l')(V := (l⇩0 ++ l) V) = l⇩0 ++ l'(V := l V)"
by(rule ext)(simp add:map_add_def)
with red_reds.InitBlockRed[OF IH'] l'V show ?case by(simp del:fun_upd_apply)
next
case (BlockRedNone e h l V e' h' l' T l⇩0)
have IH: "⋀l⇩0. P ⊢ ⟨e,(h, l⇩0 ++ l(V := None))⟩ → ⟨e',(h', l⇩0 ++ l')⟩"
and l'V: "l' V = None" and unass: "¬ assigned V e" by fact+
have "l⇩0(V := None) ++ l(V := None) = (l⇩0 ++ l)(V := None)"
by(simp add:fun_eq_iff map_add_def)
hence IH': "P ⊢ ⟨e,(h, (l⇩0++l)(V := None))⟩ → ⟨e',(h', l⇩0(V := None) ++ l')⟩"
using IH[of "l⇩0(V := None)"] by simp
have "(l⇩0(V := None) ++ l')(V := (l⇩0 ++ l) V) = l⇩0 ++ l'(V := l V)"
by(simp add:fun_eq_iff map_add_def)
with red_reds.BlockRedNone[OF IH' _ unass] l'V show ?case
by(simp add: map_add_def)
next
case (BlockRedSome e h l V e' h' l' v T l⇩0)
have IH: "⋀l⇩0. P ⊢ ⟨e,(h, l⇩0 ++ l(V := None))⟩ → ⟨e',(h', l⇩0 ++ l')⟩"
and l'V: "l' V = Some v" and unass: "¬ assigned V e" by fact+
have "l⇩0(V := None) ++ l(V := None) = (l⇩0 ++ l)(V := None)"
by(simp add:fun_eq_iff map_add_def)
hence IH': "P ⊢ ⟨e,(h, (l⇩0++l)(V := None))⟩ → ⟨e',(h', l⇩0(V := None) ++ l')⟩"
using IH[of "l⇩0(V := None)"] by simp
have "(l⇩0(V := None) ++ l')(V := (l⇩0 ++ l) V) = l⇩0 ++ l'(V := l V)"
by(simp add:fun_eq_iff map_add_def)
with red_reds.BlockRedSome[OF IH' _ unass] l'V show ?case
by(simp add:map_add_def)
next
case RedTryCatch thus ?case by(fastforce intro:red_reds.intros)
next
case RedTryFail thus ?case by(force intro!:red_reds.intros)
qed (simp_all add:red_reds.intros)
lemma Red_lcl_add:
assumes "P ⊢ ⟨e,(h,l)⟩ →* ⟨e',(h',l')⟩" shows "P ⊢ ⟨e,(h,l⇩0++l)⟩ →* ⟨e',(h',l⇩0++l')⟩"
using assms
proof(induct rule:converse_rtrancl_induct_red)
case 1 thus ?case by simp
next
case 2 thus ?case
by (blast dest: red_lcl_add intro: converse_rtrancl_into_rtrancl)
qed
end
Theory SystemClasses
section ‹System Classes›
theory SystemClasses
imports Decl Exceptions
begin
text ‹
This theory provides definitions for the ‹Object› class,
and the system exceptions.
›
definition ObjectC :: "'m cdecl"
where
"ObjectC ≡ (Object, (undefined,[],[]))"
definition NullPointerC :: "'m cdecl"
where
"NullPointerC ≡ (NullPointer, (Object,[],[]))"
definition ClassCastC :: "'m cdecl"
where
"ClassCastC ≡ (ClassCast, (Object,[],[]))"
definition OutOfMemoryC :: "'m cdecl"
where
"OutOfMemoryC ≡ (OutOfMemory, (Object,[],[]))"
definition SystemClasses :: "'m cdecl list"
where
"SystemClasses ≡ [ObjectC, NullPointerC, ClassCastC, OutOfMemoryC]"
end
Theory WellForm
section ‹Generic Well-formedness of programs›
theory WellForm imports TypeRel SystemClasses begin
text ‹\noindent This theory defines global well-formedness conditions
for programs but does not look inside method bodies. Hence it works
for both Jinja and JVM programs. Well-typing of expressions is defined
elsewhere (in theory ‹WellType›).
Because Jinja does not have method overloading, its policy for method
overriding is the classical one: \emph{covariant in the result type
but contravariant in the argument types.} This means the result type
of the overriding method becomes more specific, the argument types
become more general.
›
type_synonym 'm wf_mdecl_test = "'m prog ⇒ cname ⇒ 'm mdecl ⇒ bool"
definition wf_fdecl :: "'m prog ⇒ fdecl ⇒ bool"
where
"wf_fdecl P ≡ λ(F,T). is_type P T"
definition wf_mdecl :: "'m wf_mdecl_test ⇒ 'm wf_mdecl_test"
where
"wf_mdecl wf_md P C ≡ λ(M,Ts,T,mb).
(∀T∈set Ts. is_type P T) ∧ is_type P T ∧ wf_md P C (M,Ts,T,mb)"
definition wf_cdecl :: "'m wf_mdecl_test ⇒ 'm prog ⇒ 'm cdecl ⇒ bool"
where
"wf_cdecl wf_md P ≡ λ(C,(D,fs,ms)).
(∀f∈set fs. wf_fdecl P f) ∧ distinct_fst fs ∧
(∀m∈set ms. wf_mdecl wf_md P C m) ∧ distinct_fst ms ∧
(C ≠ Object ⟶
is_class P D ∧ ¬ P ⊢ D ≼⇧* C ∧
(∀(M,Ts,T,m)∈set ms.
∀D' Ts' T' m'. P ⊢ D sees M:Ts' → T' = m' in D' ⟶
P ⊢ Ts' [≤] Ts ∧ P ⊢ T ≤ T'))"
definition wf_syscls :: "'m prog ⇒ bool"
where
"wf_syscls P ≡ {Object} ∪ sys_xcpts ⊆ set(map fst P)"
definition wf_prog :: "'m wf_mdecl_test ⇒ 'm prog ⇒ bool"
where
"wf_prog wf_md P ≡ wf_syscls P ∧ (∀c ∈ set P. wf_cdecl wf_md P c) ∧ distinct_fst P"
subsection‹Well-formedness lemmas›
lemma class_wf:
"⟦class P C = Some c; wf_prog wf_md P⟧ ⟹ wf_cdecl wf_md P (C,c)"
apply (unfold wf_prog_def class_def)
apply (fast dest: map_of_SomeD)
done
lemma class_Object [simp]:
"wf_prog wf_md P ⟹ ∃C fs ms. class P Object = Some (C,fs,ms)"
apply (unfold wf_prog_def wf_syscls_def class_def)
apply (auto simp: map_of_SomeI)
done
lemma is_class_Object [simp]:
"wf_prog wf_md P ⟹ is_class P Object"
by (simp add: is_class_def)
lemma is_class_xcpt:
"⟦ C ∈ sys_xcpts; wf_prog wf_md P ⟧ ⟹ is_class P C"
apply (simp add: wf_prog_def wf_syscls_def is_class_def class_def)
apply (fastforce intro!: map_of_SomeI)
done
lemma subcls1_wfD:
"⟦ P ⊢ C ≺⇧1 D; wf_prog wf_md P ⟧ ⟹ D ≠ C ∧ (D,C) ∉ (subcls1 P)⇧+"
apply( frule r_into_trancl)
apply( drule subcls1D)
apply(clarify)
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def)
apply(force simp add: reflcl_trancl [THEN sym] simp del: reflcl_trancl)
done
lemma wf_cdecl_supD:
"⟦wf_cdecl wf_md P (C,D,r); C ≠ Object⟧ ⟹ is_class P D"
by (auto simp: wf_cdecl_def)
lemma subcls_asym:
"⟦ wf_prog wf_md P; (C,D) ∈ (subcls1 P)⇧+ ⟧ ⟹ (D,C) ∉ (subcls1 P)⇧+"
apply(erule tranclE)
apply(fast dest!: subcls1_wfD )
apply(fast dest!: subcls1_wfD intro: trancl_trans)
done
lemma subcls_irrefl:
"⟦ wf_prog wf_md P; (C,D) ∈ (subcls1 P)⇧+ ⟧ ⟹ C ≠ D"
apply (erule trancl_trans_induct)
apply (auto dest: subcls1_wfD subcls_asym)
done
lemma acyclic_subcls1:
"wf_prog wf_md P ⟹ acyclic (subcls1 P)"
apply (unfold acyclic_def)
apply (fast dest: subcls_irrefl)
done
lemma wf_subcls1:
"wf_prog wf_md P ⟹ wf ((subcls1 P)¯)"
apply (rule finite_acyclic_wf)
apply ( subst finite_converse)
apply ( rule finite_subcls1)
apply (subst acyclic_converse)
apply (erule acyclic_subcls1)
done
lemma single_valued_subcls1:
"wf_prog wf_md G ⟹ single_valued (subcls1 G)"
by(auto simp:wf_prog_def distinct_fst_def single_valued_def dest!:subcls1D)
lemma subcls_induct:
"⟦ wf_prog wf_md P; ⋀C. ∀D. (C,D) ∈ (subcls1 P)⇧+ ⟶ Q D ⟹ Q C ⟧ ⟹ Q C"
(is "?A ⟹ PROP ?P ⟹ _")
proof -
assume p: "PROP ?P"
assume ?A thus ?thesis apply -
apply(drule wf_subcls1)
apply(drule wf_trancl)
apply(simp only: trancl_converse)
apply(erule_tac a = C in wf_induct)
apply(rule p)
apply(auto)
done
qed
lemma subcls1_induct_aux:
"⟦ is_class P C; wf_prog wf_md P; Q Object;
⋀C D fs ms.
⟦ C ≠ Object; is_class P C; class P C = Some (D,fs,ms) ∧
wf_cdecl wf_md P (C,D,fs,ms) ∧ P ⊢ C ≺⇧1 D ∧ is_class P D ∧ Q D⟧ ⟹ Q C ⟧
⟹ Q C"
(is "?A ⟹ ?B ⟹ ?C ⟹ PROP ?P ⟹ _")
proof -
assume p: "PROP ?P"
assume ?A ?B ?C thus ?thesis apply -
apply(unfold is_class_def)
apply( rule impE)
prefer 2
apply( assumption)
prefer 2
apply( assumption)
apply( erule thin_rl)
apply( rule subcls_induct)
apply( assumption)
apply( rule impI)
apply( case_tac "C = Object")
apply( fast)
apply safe
apply( frule (1) class_wf)
apply( frule (1) wf_cdecl_supD)
apply( subgoal_tac "P ⊢ C ≺⇧1 a")
apply( erule_tac [2] subcls1I)
apply( rule p)
apply (unfold is_class_def)
apply auto
done
qed
lemma subcls1_induct [consumes 2, case_names Object Subcls]:
"⟦ wf_prog wf_md P; is_class P C; Q Object;
⋀C D. ⟦C ≠ Object; P ⊢ C ≺⇧1 D; is_class P D; Q D⟧ ⟹ Q C ⟧
⟹ Q C"
apply (erule subcls1_induct_aux, assumption, assumption)
apply blast
done
lemma subcls_C_Object:
"⟦ is_class P C; wf_prog wf_md P ⟧ ⟹ P ⊢ C ≼⇧* Object"
apply(erule (1) subcls1_induct)
apply( fast)
apply(erule (1) converse_rtrancl_into_rtrancl)
done
lemma is_type_pTs:
assumes "wf_prog wf_md P" and "(C,S,fs,ms) ∈ set P" and "(M,Ts,T,m) ∈ set ms"
shows "set Ts ⊆ types P"
proof
from assms have "wf_mdecl wf_md P C (M,Ts,T,m)"
by (unfold wf_prog_def wf_cdecl_def) auto
hence "∀t ∈ set Ts. is_type P t" by (unfold wf_mdecl_def) auto
moreover fix t assume "t ∈ set Ts"
ultimately have "is_type P t" by blast
thus "t ∈ types P" ..
qed
subsection‹Well-formedness and method lookup›
lemma sees_wf_mdecl:
"⟦ wf_prog wf_md P; P ⊢ C sees M:Ts→T = m in D ⟧ ⟹ wf_mdecl wf_md P D (M,Ts,T,m)"
apply(drule visible_method_exists)
apply(fastforce simp:wf_cdecl_def dest!:class_wf dest:map_of_SomeD)
done
lemma sees_method_mono [rule_format (no_asm)]:
"⟦ P ⊢ C' ≼⇧* C; wf_prog wf_md P ⟧ ⟹
∀D Ts T m. P ⊢ C sees M:Ts→T = m in D ⟶
(∃D' Ts' T' m'. P ⊢ C' sees M:Ts'→T' = m' in D' ∧ P ⊢ Ts [≤] Ts' ∧ P ⊢ T' ≤ T)"
apply( drule rtranclD)
apply( erule disjE)
apply( fastforce)
apply( erule conjE)
apply( erule trancl_trans_induct)
prefer 2
apply( clarify)
apply( drule spec, drule spec, drule spec, drule spec, erule (1) impE)
apply clarify
apply( fast elim: widen_trans widens_trans)
apply( clarify)
apply( drule subcls1D)
apply( clarify)
apply(clarsimp simp:Method_def)
apply(frule (2) sees_methods_rec)
apply(rule refl)
apply(case_tac "map_of ms M")
apply(rule_tac x = D in exI)
apply(rule_tac x = Ts in exI)
apply(rule_tac x = T in exI)
apply simp
apply(rule_tac x = m in exI)
apply(fastforce simp add:map_add_def split:option.split)
apply clarsimp
apply(rename_tac Ts' T' m')
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def Method_def)
apply( frule map_of_SomeD)
apply auto
apply(drule (1) bspec, simp)
apply(erule_tac x=D in allE, erule_tac x=Ts in allE, erule_tac x=T in allE)
apply(fastforce simp:map_add_def split:option.split)
done
lemma sees_method_mono2:
"⟦ P ⊢ C' ≼⇧* C; wf_prog wf_md P;
P ⊢ C sees M:Ts→T = m in D; P ⊢ C' sees M:Ts'→T' = m' in D' ⟧
⟹ P ⊢ Ts [≤] Ts' ∧ P ⊢ T' ≤ T"
by(blast dest:sees_method_mono sees_method_fun)
lemma mdecls_visible:
assumes wf: "wf_prog wf_md P" and "class": "is_class P C"
shows "⋀D fs ms. class P C = Some(D,fs,ms)
⟹ ∃Mm. P ⊢ C sees_methods Mm ∧ (∀(M,Ts,T,m) ∈ set ms. Mm M = Some((Ts,T,m),C))"
using wf "class"
proof (induct rule:subcls1_induct)
case Object
with wf have "distinct_fst ms"
by (unfold class_def wf_prog_def wf_cdecl_def) (fastforce dest:map_of_SomeD)
with Object show ?case by(fastforce intro!: sees_methods_Object map_of_SomeI)
next
case Subcls
with wf have "distinct_fst ms"
by (unfold class_def wf_prog_def wf_cdecl_def) (fastforce dest:map_of_SomeD)
with Subcls show ?case
by(fastforce elim:sees_methods_rec dest:subcls1D map_of_SomeI
simp:is_class_def)
qed
lemma mdecl_visible:
assumes wf: "wf_prog wf_md P" and C: "(C,S,fs,ms) ∈ set P" and m: "(M,Ts,T,m) ∈ set ms"
shows "P ⊢ C sees M:Ts→T = m in C"
proof -
from wf C have "class": "class P C = Some (S,fs,ms)"
by (auto simp add: wf_prog_def class_def is_class_def intro: map_of_SomeI)
from "class" have "is_class P C" by(auto simp:is_class_def)
with assms "class" show ?thesis
by(bestsimp simp:Method_def dest:mdecls_visible)
qed
lemma Call_lemma:
"⟦ P ⊢ C sees M:Ts→T = m in D; P ⊢ C' ≼⇧* C; wf_prog wf_md P ⟧
⟹ ∃D' Ts' T' m'.
P ⊢ C' sees M:Ts'→T' = m' in D' ∧ P ⊢ Ts [≤] Ts' ∧ P ⊢ T' ≤ T ∧ P ⊢ C' ≼⇧* D'
∧ is_type P T' ∧ (∀T∈set Ts'. is_type P T) ∧ wf_md P D' (M,Ts',T',m')"
apply(frule (2) sees_method_mono)
apply(fastforce intro:sees_method_decl_above dest:sees_wf_mdecl
simp: wf_mdecl_def)
done
lemma wf_prog_lift:
assumes wf: "wf_prog (λP C bd. A P C bd) P"
and rule:
"⋀wf_md C M Ts C T m bd.
wf_prog wf_md P ⟹
P ⊢ C sees M:Ts→T = m in C ⟹
set Ts ⊆ types P ⟹
bd = (M,Ts,T,m) ⟹
A P C bd ⟹
B P C bd"
shows "wf_prog (λP C bd. B P C bd) P"
proof -
from wf show ?thesis
apply (unfold wf_prog_def wf_cdecl_def)
apply clarsimp
apply (drule bspec, assumption)
apply (unfold wf_mdecl_def)
apply clarsimp
apply (drule bspec, assumption)
apply clarsimp
apply (frule mdecl_visible [OF wf], assumption+)
apply (frule is_type_pTs [OF wf], assumption+)
apply (drule rule [OF wf], assumption+)
apply auto
done
qed
subsection‹Well-formedness and field lookup›
lemma wf_Fields_Ex:
"⟦ wf_prog wf_md P; is_class P C ⟧ ⟹ ∃FDTs. P ⊢ C has_fields FDTs"
apply(frule class_Object)
apply(erule (1) subcls1_induct)
apply(blast intro:has_fields_Object)
apply(blast intro:has_fields_rec dest:subcls1D)
done
lemma has_fields_types:
"⟦ P ⊢ C has_fields FDTs; (FD,T) ∈ set FDTs; wf_prog wf_md P ⟧ ⟹ is_type P T"
apply(induct rule:Fields.induct)
apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
done
lemma sees_field_is_type:
"⟦ P ⊢ C sees F:T in D; wf_prog wf_md P ⟧ ⟹ is_type P T"
by(fastforce simp: sees_field_def
elim: has_fields_types map_of_SomeD[OF map_of_remap_SomeD])
lemma wf_syscls:
"set SystemClasses ⊆ set P ⟹ wf_syscls P"
apply (simp add: image_def SystemClasses_def wf_syscls_def sys_xcpts_def
ObjectC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def)
apply force
done
end
Theory Equivalence
section ‹Equivalence of Big Step and Small Step Semantics›
theory Equivalence imports BigStep SmallStep WWellForm begin
subsection‹Small steps simulate big step›
subsubsection "Cast"
lemma CastReds:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨Cast C e,s⟩ →* ⟨Cast C e',s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule CastRed)
done
lemma CastRedsNull:
"P ⊢ ⟨e,s⟩ →* ⟨null,s'⟩ ⟹ P ⊢ ⟨Cast C e,s⟩ →* ⟨null,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule CastReds)
apply(rule RedCastNull)
done
lemma CastRedsAddr:
"⟦ P ⊢ ⟨e,s⟩ →* ⟨addr a,s'⟩; hp s' a = Some(D,fs); P ⊢ D ≼⇧* C ⟧ ⟹
P ⊢ ⟨Cast C e,s⟩ →* ⟨addr a,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule CastReds)
apply(erule (1) RedCast)
done
lemma CastRedsFail:
"⟦ P ⊢ ⟨e,s⟩ →* ⟨addr a,s'⟩; hp s' a = Some(D,fs); ¬ P ⊢ D ≼⇧* C ⟧ ⟹
P ⊢ ⟨Cast C e,s⟩ →* ⟨THROW ClassCast,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule CastReds)
apply(erule (1) RedCastFail)
done
lemma CastRedsThrow:
"⟦ P ⊢ ⟨e,s⟩ →* ⟨throw a,s'⟩ ⟧ ⟹ P ⊢ ⟨Cast C e,s⟩ →* ⟨throw a,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule CastReds)
apply(rule red_reds.CastThrow)
done
subsubsection "LAss"
lemma LAssReds:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨ V:=e,s⟩ →* ⟨ V:=e',s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule LAssRed)
done
lemma LAssRedsVal:
"⟦ P ⊢ ⟨e,s⟩ →* ⟨Val v,(h',l')⟩ ⟧ ⟹ P ⊢ ⟨ V:=e,s⟩ →* ⟨unit,(h',l'(V↦v))⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule LAssReds)
apply(rule RedLAss)
done
lemma LAssRedsThrow:
"⟦ P ⊢ ⟨e,s⟩ →* ⟨throw a,s'⟩ ⟧ ⟹ P ⊢ ⟨ V:=e,s⟩ →* ⟨throw a,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule LAssReds)
apply(rule red_reds.LAssThrow)
done
subsubsection "BinOp"
lemma BinOp1Reds:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨ e «bop» e⇩2, s⟩ →* ⟨e' «bop» e⇩2, s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule BinOpRed1)
done
lemma BinOp2Reds:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨(Val v) «bop» e, s⟩ →* ⟨(Val v) «bop» e', s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule BinOpRed2)
done
lemma BinOpRedsVal:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ →* ⟨Val v⇩1,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ →* ⟨Val v⇩2,s⇩2⟩; binop(bop,v⇩1,v⇩2) = Some v ⟧
⟹ P ⊢ ⟨e⇩1 «bop» e⇩2, s⇩0⟩ →* ⟨Val v,s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule BinOp1Reds)
apply(rule rtrancl_into_rtrancl)
apply(erule BinOp2Reds)
apply(rule RedBinOp)
apply simp
done
lemma BinOpRedsThrow1:
"P ⊢ ⟨e,s⟩ →* ⟨throw e',s'⟩ ⟹ P ⊢ ⟨e «bop» e⇩2, s⟩ →* ⟨throw e', s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule BinOp1Reds)
apply(rule red_reds.BinOpThrow1)
done
lemma BinOpRedsThrow2:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ →* ⟨Val v⇩1,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ →* ⟨throw e,s⇩2⟩⟧
⟹ P ⊢ ⟨e⇩1 «bop» e⇩2, s⇩0⟩ →* ⟨throw e,s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule BinOp1Reds)
apply(rule rtrancl_into_rtrancl)
apply(erule BinOp2Reds)
apply(rule red_reds.BinOpThrow2)
done
subsubsection "FAcc"
lemma FAccReds:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨e∙F{D}, s⟩ →* ⟨e'∙F{D}, s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule FAccRed)
done
lemma FAccRedsVal:
"⟦P ⊢ ⟨e,s⟩ →* ⟨addr a,s'⟩; hp s' a = Some(C,fs); fs(F,D) = Some v ⟧
⟹ P ⊢ ⟨e∙F{D},s⟩ →* ⟨Val v,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule FAccReds)
apply(erule (1) RedFAcc)
done
lemma FAccRedsNull:
"P ⊢ ⟨e,s⟩ →* ⟨null,s'⟩ ⟹ P ⊢ ⟨e∙F{D},s⟩ →* ⟨THROW NullPointer,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule FAccReds)
apply(rule RedFAccNull)
done
lemma FAccRedsThrow:
"P ⊢ ⟨e,s⟩ →* ⟨throw a,s'⟩ ⟹ P ⊢ ⟨e∙F{D},s⟩ →* ⟨throw a,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule FAccReds)
apply(rule red_reds.FAccThrow)
done
subsubsection "FAss"
lemma FAssReds1:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨e∙F{D}:=e⇩2, s⟩ →* ⟨e'∙F{D}:=e⇩2, s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule FAssRed1)
done
lemma FAssReds2:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨Val v∙F{D}:=e, s⟩ →* ⟨Val v∙F{D}:=e', s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule FAssRed2)
done
lemma FAssRedsVal:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ →* ⟨addr a,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ →* ⟨Val v,(h⇩2,l⇩2)⟩; Some(C,fs) = h⇩2 a ⟧ ⟹
P ⊢ ⟨e⇩1∙F{D}:=e⇩2, s⇩0⟩ →* ⟨unit, (h⇩2(a↦(C,fs((F,D)↦v))),l⇩2)⟩"
apply(rule rtrancl_trans)
apply(erule FAssReds1)
apply(rule rtrancl_into_rtrancl)
apply(erule FAssReds2)
apply(rule RedFAss)
apply simp
done
lemma FAssRedsNull:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ →* ⟨null,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ →* ⟨Val v,s⇩2⟩ ⟧ ⟹
P ⊢ ⟨e⇩1∙F{D}:=e⇩2, s⇩0⟩ →* ⟨THROW NullPointer, s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule FAssReds1)
apply(rule rtrancl_into_rtrancl)
apply(erule FAssReds2)
apply(rule RedFAssNull)
done
lemma FAssRedsThrow1:
"P ⊢ ⟨e,s⟩ →* ⟨throw e',s'⟩ ⟹ P ⊢ ⟨e∙F{D}:=e⇩2, s⟩ →* ⟨throw e', s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule FAssReds1)
apply(rule red_reds.FAssThrow1)
done
lemma FAssRedsThrow2:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ →* ⟨Val v,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ →* ⟨throw e,s⇩2⟩ ⟧
⟹ P ⊢ ⟨e⇩1∙F{D}:=e⇩2,s⇩0⟩ →* ⟨throw e,s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule FAssReds1)
apply(rule rtrancl_into_rtrancl)
apply(erule FAssReds2)
apply(rule red_reds.FAssThrow2)
done
subsubsection";;"
lemma SeqReds:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨e;;e⇩2, s⟩ →* ⟨e';;e⇩2, s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule SeqRed)
done
lemma SeqRedsThrow:
"P ⊢ ⟨e,s⟩ →* ⟨throw e',s'⟩ ⟹ P ⊢ ⟨e;;e⇩2, s⟩ →* ⟨throw e', s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule SeqReds)
apply(rule red_reds.SeqThrow)
done
lemma SeqReds2:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ →* ⟨Val v⇩1,s⇩1⟩; P ⊢ ⟨e⇩2,s⇩1⟩ →* ⟨e⇩2',s⇩2⟩ ⟧ ⟹ P ⊢ ⟨e⇩1;;e⇩2, s⇩0⟩ →* ⟨e⇩2',s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule SeqReds)
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedSeq)
apply assumption
done
subsubsection"If"
lemma CondReds:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨if (e) e⇩1 else e⇩2,s⟩ →* ⟨if (e') e⇩1 else e⇩2,s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule CondRed)
done
lemma CondRedsThrow:
"P ⊢ ⟨e,s⟩ →* ⟨throw a,s'⟩ ⟹ P ⊢ ⟨if (e) e⇩1 else e⇩2, s⟩ →* ⟨throw a,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule CondReds)
apply(rule red_reds.CondThrow)
done
lemma CondReds2T:
"⟦P ⊢ ⟨e,s⇩0⟩ →* ⟨true,s⇩1⟩; P ⊢ ⟨e⇩1, s⇩1⟩ →* ⟨e',s⇩2⟩ ⟧ ⟹ P ⊢ ⟨if (e) e⇩1 else e⇩2, s⇩0⟩ →* ⟨e',s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule CondReds)
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedCondT)
apply assumption
done
lemma CondReds2F:
"⟦P ⊢ ⟨e,s⇩0⟩ →* ⟨false,s⇩1⟩; P ⊢ ⟨e⇩2, s⇩1⟩ →* ⟨e',s⇩2⟩ ⟧ ⟹ P ⊢ ⟨if (e) e⇩1 else e⇩2, s⇩0⟩ →* ⟨e',s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule CondReds)
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedCondF)
apply assumption
done
subsubsection "While"
lemma WhileFReds:
"P ⊢ ⟨b,s⟩ →* ⟨false,s'⟩ ⟹ P ⊢ ⟨while (b) c,s⟩ →* ⟨unit,s'⟩"
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedWhile)
apply(rule rtrancl_into_rtrancl)
apply(erule CondReds)
apply(rule RedCondF)
done
lemma WhileRedsThrow:
"P ⊢ ⟨b,s⟩ →* ⟨throw e,s'⟩ ⟹ P ⊢ ⟨while (b) c,s⟩ →* ⟨throw e,s'⟩"
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedWhile)
apply(rule rtrancl_into_rtrancl)
apply(erule CondReds)
apply(rule red_reds.CondThrow)
done
lemma WhileTReds:
"⟦ P ⊢ ⟨b,s⇩0⟩ →* ⟨true,s⇩1⟩; P ⊢ ⟨c,s⇩1⟩ →* ⟨Val v⇩1,s⇩2⟩; P ⊢ ⟨while (b) c,s⇩2⟩ →* ⟨e,s⇩3⟩ ⟧
⟹ P ⊢ ⟨while (b) c,s⇩0⟩ →* ⟨e,s⇩3⟩"
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedWhile)
apply(rule rtrancl_trans)
apply(erule CondReds)
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedCondT)
apply(rule rtrancl_trans)
apply(erule SeqReds)
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedSeq)
apply assumption
done
lemma WhileTRedsThrow:
"⟦ P ⊢ ⟨b,s⇩0⟩ →* ⟨true,s⇩1⟩; P ⊢ ⟨c,s⇩1⟩ →* ⟨throw e,s⇩2⟩ ⟧
⟹ P ⊢ ⟨while (b) c,s⇩0⟩ →* ⟨throw e,s⇩2⟩"
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedWhile)
apply(rule rtrancl_trans)
apply(erule CondReds)
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedCondT)
apply(rule rtrancl_into_rtrancl)
apply(erule SeqReds)
apply(rule red_reds.SeqThrow)
done
subsubsection"Throw"
lemma ThrowReds:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨throw e,s⟩ →* ⟨throw e',s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule ThrowRed)
done
lemma ThrowRedsNull:
"P ⊢ ⟨e,s⟩ →* ⟨null,s'⟩ ⟹ P ⊢ ⟨throw e,s⟩ →* ⟨THROW NullPointer,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule ThrowReds)
apply(rule RedThrowNull)
done
lemma ThrowRedsThrow:
"P ⊢ ⟨e,s⟩ →* ⟨throw a,s'⟩ ⟹ P ⊢ ⟨throw e,s⟩ →* ⟨throw a,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule ThrowReds)
apply(rule red_reds.ThrowThrow)
done
subsubsection "InitBlock"
lemma InitBlockReds_aux:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹
∀h l h' l' v. s = (h,l(V↦v)) ⟶ s' = (h',l') ⟶
P ⊢ ⟨{V:T := Val v; e},(h,l)⟩ →* ⟨{V:T := Val(the(l' V)); e'},(h',l'(V:=(l V)))⟩"
apply(erule converse_rtrancl_induct2)
apply(fastforce simp: fun_upd_same simp del:fun_upd_apply)
apply clarify
apply(rename_tac e0 X Y e1 h1 l1 h0 l0 h2 l2 v0)
apply(subgoal_tac "V ∈ dom l1")
prefer 2
apply(drule red_lcl_incr)
apply simp
apply clarsimp
apply(rename_tac v1)
apply(rule converse_rtrancl_into_rtrancl)
apply(rule InitBlockRed)
apply assumption
apply simp
apply(erule_tac x = "l1(V := l0 V)" in allE)
apply(erule_tac x = v1 in allE)
apply(erule impE)
apply(rule ext)
apply(simp add:fun_upd_def)
apply(simp add:fun_upd_def)
done
lemma InitBlockReds:
"P ⊢ ⟨e, (h,l(V↦v))⟩ →* ⟨e', (h',l')⟩ ⟹
P ⊢ ⟨{V:T := Val v; e}, (h,l)⟩ →* ⟨{V:T := Val(the(l' V)); e'}, (h',l'(V:=(l V)))⟩"
by(blast dest:InitBlockReds_aux)
lemma InitBlockRedsFinal:
"⟦ P ⊢ ⟨e,(h,l(V↦v))⟩ →* ⟨e',(h',l')⟩; final e' ⟧ ⟹
P ⊢ ⟨{V:T := Val v; e},(h,l)⟩ →* ⟨e',(h', l'(V := l V))⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule InitBlockReds)
apply(fast elim!:finalE intro:RedInitBlock InitBlockThrow)
done
subsubsection "Block"
lemma BlockRedsFinal:
assumes reds: "P ⊢ ⟨e⇩0,s⇩0⟩ →* ⟨e⇩2,(h⇩2,l⇩2)⟩" and fin: "final e⇩2"
shows "⋀h⇩0 l⇩0. s⇩0 = (h⇩0,l⇩0(V:=None)) ⟹ P ⊢ ⟨{V:T; e⇩0},(h⇩0,l⇩0)⟩ →* ⟨e⇩2,(h⇩2,l⇩2(V:=l⇩0 V))⟩"
using reds
proof (induct rule:converse_rtrancl_induct2)
case refl thus ?case
by(fastforce intro:finalE[OF fin] RedBlock BlockThrow
simp del:fun_upd_apply)
next
case (step e⇩0 s⇩0 e⇩1 s⇩1)
have red: "P ⊢ ⟨e⇩0,s⇩0⟩ → ⟨e⇩1,s⇩1⟩"
and reds: "P ⊢ ⟨e⇩1,s⇩1⟩ →* ⟨e⇩2,(h⇩2,l⇩2)⟩"
and IH: "⋀h l. s⇩1 = (h,l(V := None))
⟹ P ⊢ ⟨{V:T; e⇩1},(h,l)⟩ →* ⟨e⇩2,(h⇩2, l⇩2(V := l V))⟩"
and s⇩0: "s⇩0 = (h⇩0, l⇩0(V := None))" by fact+
obtain h⇩1 l⇩1 where s⇩1: "s⇩1 = (h⇩1,l⇩1)" by fastforce
show ?case
proof cases
assume "assigned V e⇩0"
then obtain v e where e⇩0: "e⇩0 = V := Val v;; e"
by (unfold assigned_def)blast
from red e⇩0 s⇩0 have e⇩1: "e⇩1 = unit;;e" and s⇩1: "s⇩1 = (h⇩0, l⇩0(V ↦ v))"
by auto
from e⇩1 fin have "e⇩1 ≠ e⇩2" by (auto simp:final_def)
then obtain e' s' where red1: "P ⊢ ⟨e⇩1,s⇩1⟩ → ⟨e',s'⟩"
and reds': "P ⊢ ⟨e',s'⟩ →* ⟨e⇩2,(h⇩2,l⇩2)⟩"
using converse_rtranclE2[OF reds] by blast
from red1 e⇩1 have es': "e' = e" "s' = s⇩1" by auto
show ?case using e⇩0 s⇩1 es' reds'
by(fastforce intro!: InitBlockRedsFinal[OF _ fin] simp del:fun_upd_apply)
next
assume unass: "¬ assigned V e⇩0"
show ?thesis
proof (cases "l⇩1 V")
assume None: "l⇩1 V = None"
hence "P ⊢ ⟨{V:T; e⇩0},(h⇩0,l⇩0)⟩ → ⟨{V:T; e⇩1},(h⇩1, l⇩1(V := l⇩0 V))⟩"
using s⇩0 s⇩1 red by(simp add: BlockRedNone[OF _ _ unass])
moreover
have "P ⊢ ⟨{V:T; e⇩1},(h⇩1, l⇩1(V := l⇩0 V))⟩ →* ⟨e⇩2,(h⇩2, l⇩2(V := l⇩0 V))⟩"
using IH[of _ "l⇩1(V := l⇩0 V)"] s⇩1 None by(simp add:fun_upd_idem)
ultimately show ?case by(rule converse_rtrancl_into_rtrancl)
next
fix v assume Some: "l⇩1 V = Some v"
hence "P ⊢ ⟨{V:T;e⇩0},(h⇩0,l⇩0)⟩ → ⟨{V:T := Val v; e⇩1},(h⇩1,l⇩1(V := l⇩0 V))⟩"
using s⇩0 s⇩1 red by(simp add: BlockRedSome[OF _ _ unass])
moreover
have "P ⊢ ⟨{V:T := Val v; e⇩1},(h⇩1,l⇩1(V:= l⇩0 V))⟩ →*
⟨e⇩2,(h⇩2,l⇩2(V:=l⇩0 V))⟩"
using InitBlockRedsFinal[OF _ fin,of _ _ "l⇩1(V:=l⇩0 V)" V]
Some reds s⇩1 by(simp add:fun_upd_idem)
ultimately show ?case by(rule converse_rtrancl_into_rtrancl)
qed
qed
qed
subsubsection "try-catch"
lemma TryReds:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨try e catch(C V) e⇩2,s⟩ →* ⟨try e' catch(C V) e⇩2,s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule TryRed)
done
lemma TryRedsVal:
"P ⊢ ⟨e,s⟩ →* ⟨Val v,s'⟩ ⟹ P ⊢ ⟨try e catch(C V) e⇩2,s⟩ →* ⟨Val v,s'⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule TryReds)
apply(rule RedTry)
done
lemma TryCatchRedsFinal:
"⟦ P ⊢ ⟨e⇩1,s⇩0⟩ →* ⟨Throw a,(h⇩1,l⇩1)⟩; h⇩1 a = Some(D,fs); P ⊢ D ≼⇧* C;
P ⊢ ⟨e⇩2, (h⇩1, l⇩1(V ↦ Addr a))⟩ →* ⟨e⇩2', (h⇩2,l⇩2)⟩; final e⇩2' ⟧
⟹ P ⊢ ⟨try e⇩1 catch(C V) e⇩2, s⇩0⟩ →* ⟨e⇩2', (h⇩2, l⇩2(V := l⇩1 V))⟩"
apply(rule rtrancl_trans)
apply(erule TryReds)
apply(rule converse_rtrancl_into_rtrancl)
apply(rule RedTryCatch)
apply fastforce
apply assumption
apply(rule InitBlockRedsFinal)
apply assumption
apply(simp)
done
lemma TryRedsFail:
"⟦ P ⊢ ⟨e⇩1,s⟩ →* ⟨Throw a,(h,l)⟩; h a = Some(D,fs); ¬ P ⊢ D ≼⇧* C ⟧
⟹ P ⊢ ⟨try e⇩1 catch(C V) e⇩2,s⟩ →* ⟨Throw a,(h,l)⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule TryReds)
apply(fastforce intro!: RedTryFail)
done
subsubsection "List"
lemma ListReds1:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨e#es,s⟩ [→]* ⟨e' # es,s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule ListRed1)
done
lemma ListReds2:
"P ⊢ ⟨es,s⟩ [→]* ⟨es',s'⟩ ⟹ P ⊢ ⟨Val v # es,s⟩ [→]* ⟨Val v # es',s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule ListRed2)
done
lemma ListRedsVal:
"⟦ P ⊢ ⟨e,s⇩0⟩ →* ⟨Val v,s⇩1⟩; P ⊢ ⟨es,s⇩1⟩ [→]* ⟨es',s⇩2⟩ ⟧
⟹ P ⊢ ⟨e#es,s⇩0⟩ [→]* ⟨Val v # es',s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule ListReds1)
apply(erule ListReds2)
done
subsubsection"Call"
text‹First a few lemmas on what happens to free variables during redction.›
lemma assumes wf: "wwf_J_prog P"
shows Red_fv: "P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩ ⟹ fv e' ⊆ fv e"
and "P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩ ⟹ fvs es' ⊆ fvs es"
proof (induct rule:red_reds_inducts)
case (RedCall h l a C fs M Ts T pns body D vs)
hence "fv body ⊆ {this} ∪ set pns"
using assms by(fastforce dest!:sees_wf_mdecl simp:wf_mdecl_def)
with RedCall.hyps show ?case by fastforce
qed auto
lemma Red_dom_lcl:
"P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩ ⟹ dom l' ⊆ dom l ∪ fv e" and
"P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩ ⟹ dom l' ⊆ dom l ∪ fvs es"
proof (induct rule:red_reds_inducts)
case RedLAss thus ?case by(force split:if_splits)
next
case CallParams thus ?case by(force split:if_splits)
next
case BlockRedNone thus ?case by clarsimp (fastforce split:if_splits)
next
case BlockRedSome thus ?case by clarsimp (fastforce split:if_splits)
next
case InitBlockRed thus ?case by clarsimp (fastforce split:if_splits)
qed auto
lemma Reds_dom_lcl:
"⟦ wwf_J_prog P; P ⊢ ⟨e,(h,l)⟩ →* ⟨e',(h',l')⟩ ⟧ ⟹ dom l' ⊆ dom l ∪ fv e"
apply(erule converse_rtrancl_induct_red)
apply blast
apply(blast dest: Red_fv Red_dom_lcl)
done
text‹Now a few lemmas on the behaviour of blocks during reduction.›
lemma override_on_upd_lemma:
"(override_on f (g(a↦b)) A)(a := g a) = override_on f g (insert a A)"
apply(rule ext)
apply(simp add:override_on_def)
done
declare fun_upd_apply[simp del] map_upds_twist[simp del]
lemma blocksReds:
"⋀l. ⟦ length Vs = length Ts; length vs = length Ts; distinct Vs;
P ⊢ ⟨e, (h,l(Vs [↦] vs))⟩ →* ⟨e', (h',l')⟩ ⟧
⟹ P ⊢ ⟨blocks(Vs,Ts,vs,e), (h,l)⟩ →* ⟨blocks(Vs,Ts,map (the ∘ l') Vs,e'), (h',override_on l' l (set Vs))⟩"
proof(induct Vs Ts vs e rule:blocks_induct)
case (1 V Vs T Ts v vs e) show ?case
using InitBlockReds[OF "1.hyps"[of "l(V↦v)"]] "1.prems"
by(auto simp:override_on_upd_lemma)
qed auto
lemma blocksFinal:
"⋀l. ⟦ length Vs = length Ts; length vs = length Ts; final e ⟧ ⟹
P ⊢ ⟨blocks(Vs,Ts,vs,e), (h,l)⟩ →* ⟨e, (h,l)⟩"
proof(induct Vs Ts vs e rule:blocks_induct)
case 1
show ?case using "1.prems" InitBlockReds[OF "1.hyps"]
by(fastforce elim!:finalE elim: rtrancl_into_rtrancl[OF _ RedInitBlock]
rtrancl_into_rtrancl[OF _ InitBlockThrow])
qed auto
lemma blocksRedsFinal:
assumes wf: "length Vs = length Ts" "length vs = length Ts" "distinct Vs"
and reds: "P ⊢ ⟨e, (h,l(Vs [↦] vs))⟩ →* ⟨e', (h',l')⟩"
and fin: "final e'" and l'': "l'' = override_on l' l (set Vs)"
shows "P ⊢ ⟨blocks(Vs,Ts,vs,e), (h,l)⟩ →* ⟨e', (h',l'')⟩"
proof -
let ?bv = "blocks(Vs,Ts,map (the o l') Vs,e')"
have "P ⊢ ⟨blocks(Vs,Ts,vs,e), (h,l)⟩ →* ⟨?bv, (h',l'')⟩"
using l'' by simp (rule blocksReds[OF wf reds])
also have "P ⊢ ⟨?bv, (h',l'')⟩ →* ⟨e', (h',l'')⟩"
using wf by(fastforce intro:blocksFinal fin)
finally show ?thesis .
qed
text‹An now the actual method call reduction lemmas.›
lemma CallRedsObj:
"P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ⟹ P ⊢ ⟨e∙M(es),s⟩ →* ⟨e'∙M(es),s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule CallObj)
done
lemma CallRedsParams:
"P ⊢ ⟨es,s⟩ [→]* ⟨es',s'⟩ ⟹ P ⊢ ⟨(Val v)∙M(es),s⟩ →* ⟨(Val v)∙M(es'),s'⟩"
apply(erule rtrancl_induct2)
apply blast
apply(erule rtrancl_into_rtrancl)
apply(erule CallParams)
done
lemma CallRedsFinal:
assumes wwf: "wwf_J_prog P"
and "P ⊢ ⟨e,s⇩0⟩ →* ⟨addr a,s⇩1⟩"
"P ⊢ ⟨es,s⇩1⟩ [→]* ⟨map Val vs,(h⇩2,l⇩2)⟩"
"h⇩2 a = Some(C,fs)" "P ⊢ C sees M:Ts→T = (pns,body) in D"
"size vs = size pns"
and l⇩2': "l⇩2' = [this ↦ Addr a, pns[↦]vs]"
and body: "P ⊢ ⟨body,(h⇩2,l⇩2')⟩ →* ⟨ef,(h⇩3,l⇩3)⟩"
and "final ef"
shows "P ⊢ ⟨e∙M(es), s⇩0⟩ →* ⟨ef,(h⇩3,l⇩2)⟩"
proof -
have wf: "size Ts = size pns ∧ distinct pns ∧ this ∉ set pns"
and wt: "fv body ⊆ {this} ∪ set pns"
using assms by(fastforce dest!:sees_wf_mdecl simp:wf_mdecl_def)+
from body[THEN Red_lcl_add, of l⇩2]
have body': "P ⊢ ⟨body,(h⇩2,l⇩2(this↦ Addr a, pns[↦]vs))⟩ →* ⟨ef,(h⇩3,l⇩2++l⇩3)⟩"
by (simp add:l⇩2')
have "dom l⇩3 ⊆ {this} ∪ set pns"
using Reds_dom_lcl[OF wwf body] wt l⇩2' set_take_subset by force
hence eql⇩2: "override_on (l⇩2++l⇩3) l⇩2 ({this} ∪ set pns) = l⇩2"
by(fastforce simp add:map_add_def override_on_def fun_eq_iff)
have "P ⊢ ⟨e∙M(es),s⇩0⟩ →* ⟨(addr a)∙M(es),s⇩1⟩" by(rule CallRedsObj)(rule assms(2))
also have "P ⊢ ⟨(addr a)∙M(es),s⇩1⟩ →*
⟨(addr a)∙M(map Val vs),(h⇩2,l⇩2)⟩"
by(rule CallRedsParams)(rule assms(3))
also have "P ⊢ ⟨(addr a)∙M(map Val vs), (h⇩2,l⇩2)⟩ →
⟨blocks(this#pns, Class D#Ts, Addr a#vs, body), (h⇩2,l⇩2)⟩"
by(rule RedCall)(auto simp: assms wf, rule assms(5))
also (rtrancl_into_rtrancl) have "P ⊢ ⟨blocks(this#pns, Class D#Ts, Addr a#vs, body), (h⇩2,l⇩2)⟩
→* ⟨ef,(h⇩3,override_on (l⇩2++l⇩3) l⇩2 ({this} ∪ set pns))⟩"
by(rule blocksRedsFinal, insert assms wf body', simp_all)
finally show ?thesis using eql⇩2 by simp
qed
lemma CallRedsThrowParams:
"⟦ P ⊢ ⟨e,s0⟩ →* ⟨Val v,s⇩1⟩; P ⊢ ⟨es,s⇩1⟩ [→]* ⟨map Val vs⇩1 @ throw a # es⇩2,s⇩2⟩ ⟧
⟹ P ⊢ ⟨e∙M(es),s0⟩ →* ⟨throw a,s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule CallRedsObj)
apply(rule rtrancl_into_rtrancl)
apply(erule CallRedsParams)
apply(rule CallThrowParams)
apply simp
done
lemma CallRedsThrowObj:
"P ⊢ ⟨e,s0⟩ →* ⟨throw a,s⇩1⟩ ⟹ P ⊢ ⟨e∙M(es),s0⟩ →* ⟨throw a,s⇩1⟩"
apply(rule rtrancl_into_rtrancl)
apply(erule CallRedsObj)
apply(rule CallThrowObj)
done
lemma CallRedsNull:
"⟦ P ⊢ ⟨e,s⇩0⟩ →* ⟨null,s⇩1⟩; P ⊢ ⟨es,s⇩1⟩ [→]* ⟨map Val vs,s⇩2⟩ ⟧
⟹ P ⊢ ⟨e∙M(es),s⇩0⟩ →* ⟨THROW NullPointer,s⇩2⟩"
apply(rule rtrancl_trans)
apply(erule CallRedsObj)
apply(rule rtrancl_into_rtrancl)
apply(erule CallRedsParams)
apply(rule RedCallNull)
done
subsubsection "The main Theorem"
lemma assumes wwf: "wwf_J_prog P"
shows big_by_small: "P ⊢ ⟨e,s⟩ ⇒ ⟨e',s'⟩ ⟹ P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩"
and bigs_by_smalls: "P ⊢ ⟨es,s⟩ [⇒] ⟨es',s'⟩ ⟹ P ⊢ ⟨es,s⟩ [→]* ⟨es',s'⟩"
proof (induct rule: eval_evals.inducts)
case New thus ?case by (auto simp:RedNew)
next
case NewFail thus ?case by (auto simp:RedNewFail)
next
case Cast thus ?case by(fastforce intro:CastRedsAddr)
next
case CastNull thus ?case by(simp add:CastRedsNull)
next
case CastFail thus ?case by(fastforce intro!:CastRedsFail)
next
case CastThrow thus ?case by(auto dest!:eval_final simp:CastRedsThrow)
next
case Val thus ?case by simp
next
case BinOp thus ?case by(auto simp:BinOpRedsVal)
next
case BinOpThrow1 thus ?case by(auto dest!:eval_final simp: BinOpRedsThrow1)
next
case BinOpThrow2 thus ?case by(auto dest!:eval_final simp: BinOpRedsThrow2)
next
case Var thus ?case by (auto simp:RedVar)
next
case LAss thus ?case by(auto simp: LAssRedsVal)
next
case LAssThrow thus ?case by(auto dest!:eval_final simp: LAssRedsThrow)
next
case FAcc thus ?case by(auto intro:FAccRedsVal)
next
case FAccNull thus ?case by(simp add:FAccRedsNull)
next
case FAccThrow thus ?case by(auto dest!:eval_final simp:FAccRedsThrow)
next
case FAss thus ?case by(auto simp:FAssRedsVal)
next
case FAssNull thus ?case by(auto simp:FAssRedsNull)
next
case FAssThrow1 thus ?case by(auto dest!:eval_final simp:FAssRedsThrow1)
next
case FAssThrow2 thus ?case by(auto dest!:eval_final simp:FAssRedsThrow2)
next
case CallObjThrow thus ?case by(auto dest!:eval_final simp:CallRedsThrowObj)
next
case CallNull thus ?case by(simp add:CallRedsNull)
next
case CallParamsThrow thus ?case
by(auto dest!:evals_final simp:CallRedsThrowParams)
next
case (Call e s⇩0 a s⇩1 ps vs h⇩2 l⇩2 C fs M Ts T pns body D l⇩2' e' h⇩3 l⇩3)
have IHe: "P ⊢ ⟨e,s⇩0⟩ →* ⟨addr a,s⇩1⟩"
and IHes: "P ⊢ ⟨ps,s⇩1⟩ [→]* ⟨map Val vs,(h⇩2,l⇩2)⟩"
and h⇩2a: "h⇩2 a = Some(C,fs)"
and "method": "P ⊢ C sees M:Ts→T = (pns,body) in D"
and same_length: "length vs = length pns"
and l⇩2': "l⇩2' = [this ↦ Addr a, pns[↦]vs]"
and eval_body: "P ⊢ ⟨body,(h⇩2, l⇩2')⟩ ⇒ ⟨e',(h⇩3, l⇩3)⟩"
and IHbody: "P ⊢ ⟨body,(h⇩2,l⇩2')⟩ →* ⟨e',(h⇩3,l⇩3)⟩" by fact+
show "P ⊢ ⟨e∙M(ps),s⇩0⟩ →* ⟨e',(h⇩3, l⇩2)⟩"
using "method" same_length l⇩2' h⇩2a IHbody eval_final[OF eval_body]
by(fastforce intro:CallRedsFinal[OF wwf IHe IHes])
next
case Block thus ?case by(auto simp: BlockRedsFinal dest:eval_final)
next
case Seq thus ?case by(auto simp:SeqReds2)
next
case SeqThrow thus ?case by(auto dest!:eval_final simp: SeqRedsThrow)
next
case CondT thus ?case by(auto simp:CondReds2T)
next
case CondF thus ?case by(auto simp:CondReds2F)
next
case CondThrow thus ?case by(auto dest!:eval_final simp:CondRedsThrow)
next
case WhileF thus ?case by(auto simp:WhileFReds)
next
case WhileT thus ?case by(auto simp: WhileTReds)
next
case WhileCondThrow thus ?case by(auto dest!:eval_final simp: WhileRedsThrow)
next
case WhileBodyThrow thus ?case by(auto dest!:eval_final simp: WhileTRedsThrow)
next
case Throw thus ?case by(auto simp:ThrowReds)
next
case ThrowNull thus ?case by(auto simp:ThrowRedsNull)
next
case ThrowThrow thus ?case by(auto dest!:eval_final simp:ThrowRedsThrow)
next
case Try thus ?case by(simp add:TryRedsVal)
next
case TryCatch thus ?case by(fast intro!: TryCatchRedsFinal dest!:eval_final)
next
case TryThrow thus ?case by(fastforce intro!:TryRedsFail)
next
case Nil thus ?case by simp
next
case Cons thus ?case
by(fastforce intro!:Cons_eq_appendI[OF refl refl] ListRedsVal)
next
case ConsThrow thus ?case by(fastforce elim: ListReds1)
qed
subsection‹Big steps simulates small step›
text‹This direction was carried out by Norbert Schirmer and Daniel
Wasserrab.›
text ‹The big step equivalent of ‹RedWhile›:›
lemma unfold_while:
"P ⊢ ⟨while(b) c,s⟩ ⇒ ⟨e',s'⟩ = P ⊢ ⟨if(b) (c;;while(b) c) else (unit),s⟩ ⇒ ⟨e',s'⟩"
proof
assume "P ⊢ ⟨while (b) c,s⟩ ⇒ ⟨e',s'⟩"
thus "P ⊢ ⟨if (b) (c;; while (b) c) else unit,s⟩ ⇒ ⟨e',s'⟩"
by cases (fastforce intro: eval_evals.intros)+
next
assume "P ⊢ ⟨if (b) (c;; while (b) c) else unit,s⟩ ⇒ ⟨e',s'⟩"
thus "P ⊢ ⟨while (b) c,s⟩ ⇒ ⟨e',s'⟩"
proof (cases)
fix a
assume e': "e' = throw a"
assume "P ⊢ ⟨b,s⟩ ⇒ ⟨throw a,s'⟩"
hence "P ⊢ ⟨while(b) c,s⟩ ⇒ ⟨throw a,s'⟩" by (rule WhileCondThrow)
with e' show ?thesis by simp
next
fix s⇩1
assume eval_false: "P ⊢ ⟨b,s⟩ ⇒ ⟨false,s⇩1⟩"
and eval_unit: "P ⊢ ⟨unit,s⇩1⟩ ⇒ ⟨e',s'⟩"
with eval_unit have "s' = s⇩1" "e' = unit" by (auto elim: eval_cases)
moreover from eval_false have "P ⊢ ⟨while (b) c,s⟩ ⇒ ⟨unit,s⇩1⟩"
by - (rule WhileF, simp)
ultimately show ?thesis by simp
next
fix s⇩1
assume eval_true: "P ⊢ ⟨b,s⟩ ⇒ ⟨true,s⇩1⟩"
and eval_rest: "P ⊢ ⟨c;; while (b) c,s⇩1⟩⇒⟨e',s'⟩"
from eval_rest show ?thesis
proof (cases)
fix s⇩2 v⇩1
assume "P ⊢ ⟨c,s⇩1⟩ ⇒ ⟨Val v⇩1,s⇩2⟩" "P ⊢ ⟨while (b) c,s⇩2⟩ ⇒ ⟨e',s'⟩"
with eval_true show "P ⊢ ⟨while(b) c,s⟩ ⇒ ⟨e',s'⟩" by (rule WhileT)
next
fix a
assume "P ⊢ ⟨c,s⇩1⟩ ⇒ ⟨throw a,s'⟩" "e' = throw a"
with eval_true show "P ⊢ ⟨while(b) c,s⟩ ⇒ ⟨e',s'⟩"
by (iprover intro: WhileBodyThrow)
qed
qed
qed
lemma blocksEval:
"⋀Ts vs l l'. ⟦size ps = size Ts; size ps = size vs; P ⊢ ⟨blocks(ps,Ts,vs,e),(h,l)⟩ ⇒ ⟨e',(h',l')⟩ ⟧
⟹ ∃ l''. P ⊢ ⟨e,(h,l(ps[↦]vs))⟩ ⇒ ⟨e',(h',l'')⟩"
proof (induct ps)
case Nil then show ?case by fastforce
next
case (Cons p ps')
have length_eqs: "length (p # ps') = length Ts"
"length (p # ps') = length vs" by fact+
then obtain T Ts' where Ts: "Ts = T#Ts'" by (cases "Ts") simp
obtain v vs' where vs: "vs = v#vs'" using length_eqs by (cases "vs") simp
have "P ⊢ ⟨blocks (p # ps', Ts, vs, e),(h,l)⟩ ⇒ ⟨e',(h', l')⟩" by fact
with Ts vs
have "P ⊢ ⟨{p:T := Val v; blocks (ps', Ts', vs', e)},(h,l)⟩ ⇒ ⟨e',(h', l')⟩"
by simp
then obtain l''' where
eval_ps': "P ⊢ ⟨blocks (ps', Ts', vs', e),(h, l(p↦v))⟩ ⇒ ⟨e',(h', l''')⟩"
and l''': "l'=l'''(p:=l p)"
by (auto elim!: eval_cases)
then obtain l'' where
hyp: "P ⊢ ⟨e,(h, l(p↦v)(ps'[↦]vs'))⟩ ⇒ ⟨e',(h', l'')⟩"
using length_eqs Ts vs Cons.hyps [OF _ _ eval_ps'] by auto
from hyp
show "∃l''. P ⊢ ⟨e,(h, l(p # ps'[↦]vs))⟩ ⇒ ⟨e',(h', l'')⟩"
using Ts vs by auto
qed
lemma
assumes wf: "wwf_J_prog P"
shows eval_restrict_lcl:
"P ⊢ ⟨e,(h,l)⟩ ⇒ ⟨e',(h',l')⟩ ⟹ (⋀W. fv e ⊆ W ⟹ P ⊢ ⟨e,(h,l|`W)⟩ ⇒ ⟨e',(h',l'|`W)⟩)"
and "P ⊢ ⟨es,(h,l)⟩ [⇒] ⟨es',(h',l')⟩ ⟹ (⋀W. fvs es ⊆ W ⟹ P ⊢ ⟨es,(h,l|`W)⟩ [⇒] ⟨es',(h',l'|`W)⟩)"
proof(induct rule:eval_evals_inducts)
case (Block e⇩0 h⇩0 l⇩0 V e⇩1 h⇩1 l⇩1 T)
have IH: "⋀W. fv e⇩0 ⊆ W ⟹ P ⊢ ⟨e⇩0,(h⇩0,l⇩0(V:=None)|`W)⟩ ⇒ ⟨e⇩1,(h⇩1,l⇩1|`W)⟩" by fact
have "fv({V:T; e⇩0}) ⊆ W" by fact+
hence "fv e⇩0 - {V} ⊆ W" by simp_all
hence "fv e⇩0 ⊆ insert V W" by fast
from IH[OF this]
have "P ⊢ ⟨e⇩0,(h⇩0, (l⇩0|`W)(V := None))⟩ ⇒ ⟨e⇩1,(h⇩1, l⇩1|`insert V W)⟩"
by fastforce
from eval_evals.Block[OF this] show ?case by fastforce
next
case Seq thus ?case by simp (blast intro:eval_evals.Seq)
next
case New thus ?case by(simp add:eval_evals.intros)
next
case NewFail thus ?case by(simp add:eval_evals.intros)
next
case Cast thus ?case by simp (blast intro:eval_evals.Cast)
next
case CastNull thus ?case by simp (blast intro:eval_evals.CastNull)
next
case CastFail thus ?case by simp (blast intro:eval_evals.CastFail)
next
case CastThrow thus ?case by(simp add:eval_evals.intros)
next
case Val thus ?case by(simp add:eval_evals.intros)
next
case BinOp thus ?case by simp (blast intro:eval_evals.BinOp)
next
case BinOpThrow1 thus ?case by simp (blast intro:eval_evals.BinOpThrow1)
next
case BinOpThrow2 thus ?case by simp (blast intro:eval_evals.BinOpThrow2)
next
case Var thus ?case by(simp add:eval_evals.intros)
next
case (LAss e h⇩0 l⇩0 v h l l' V)
have IH: "⋀W. fv e ⊆ W ⟹ P ⊢ ⟨e,(h⇩0,l⇩0|`W)⟩ ⇒ ⟨Val v,(h,l|`W)⟩"
and [simp]: "l' = l(V ↦ v)" by fact+
have "fv (V:=e) ⊆ W" by fact
hence fv: "fv e ⊆ W" and VinW: "V ∈ W" by auto
from eval_evals.LAss[OF IH[OF fv] refl, of V] VinW
show ?case by simp
next
case LAssThrow thus ?case by(fastforce intro: eval_evals.LAssThrow)
next
case FAcc thus ?case by simp (blast intro: eval_evals.FAcc)
next
case FAccNull thus ?case by(fastforce intro: eval_evals.FAccNull)
next
case FAccThrow thus ?case by(fastforce intro: eval_evals.FAccThrow)
next
case FAss thus ?case by simp (blast intro: eval_evals.FAss)
next
case FAssNull thus ?case by simp (blast intro: eval_evals.FAssNull)
next
case FAssThrow1 thus ?case by simp (blast intro: eval_evals.FAssThrow1)
next
case FAssThrow2 thus ?case by simp (blast intro: eval_evals.FAssThrow2)
next
case CallObjThrow thus ?case by simp (blast intro: eval_evals.intros)
next
case CallNull thus ?case by simp (blast intro: eval_evals.CallNull)
next
case CallParamsThrow thus ?case
by simp (blast intro: eval_evals.CallParamsThrow)
next
case (Call e h⇩0 l⇩0 a h⇩1 l⇩1 ps vs h⇩2 l⇩2 C fs M Ts T pns body
D l⇩2' e' h⇩3 l⇩3)
have IHe: "⋀W. fv e ⊆ W ⟹ P ⊢ ⟨e,(h⇩0,l⇩0|`W)⟩ ⇒ ⟨addr a,(h⇩1,l⇩1|`W)⟩"
and IHps: "⋀W. fvs ps ⊆ W ⟹ P ⊢ ⟨ps,(h⇩1,l⇩1|`W)⟩ [⇒] ⟨map Val vs,(h⇩2,l⇩2|`W)⟩"
and IHbd: "⋀W. fv body ⊆ W ⟹ P ⊢ ⟨body,(h⇩2,l⇩2'|`W)⟩ ⇒ ⟨e',(h⇩3,l⇩3|`W)⟩"
and h⇩2a: "h⇩2 a = Some (C, fs)"
and "method": "P ⊢ C sees M: Ts→T = (pns, body) in D"
and same_len: "size vs = size pns"
and l⇩2': "l⇩2' = [this ↦ Addr a, pns [↦] vs]" by fact+
have "fv (e∙M(ps)) ⊆ W" by fact
hence fve: "fv e ⊆ W" and fvps: "fvs(ps) ⊆ W" by auto
have wfmethod: "size Ts = size pns ∧ this ∉ set pns" and
fvbd: "fv body ⊆ {this} ∪ set pns"
using "method" wf by(fastforce dest!:sees_wf_mdecl simp:wf_mdecl_def)+
show ?case
using IHbd[OF fvbd] l⇩2' same_len wfmethod h⇩2a
eval_evals.Call[OF IHe[OF fve] IHps[OF fvps] _ "method" same_len l⇩2']
by (simp add:subset_insertI)
next
case SeqThrow thus ?case by simp (blast intro: eval_evals.SeqThrow)
next
case CondT thus ?case by simp (blast intro: eval_evals.CondT)
next
case CondF thus ?case by simp (blast intro: eval_evals.CondF)
next
case CondThrow thus ?case by simp (blast intro: eval_evals.CondThrow)
next
case WhileF thus ?case by simp (blast intro: eval_evals.WhileF)
next
case WhileT thus ?case by simp (blast intro: eval_evals.WhileT)
next
case WhileCondThrow thus ?case by simp (blast intro: eval_evals.WhileCondThrow)
next
case WhileBodyThrow thus ?case by simp (blast intro: eval_evals.WhileBodyThrow)
next
case Throw thus ?case by simp (blast intro: eval_evals.Throw)
next
case ThrowNull thus ?case by simp (blast intro: eval_evals.ThrowNull)
next
case ThrowThrow thus ?case by simp (blast intro: eval_evals.ThrowThrow)
next
case Try thus ?case by simp (blast intro: eval_evals.Try)
next
case (TryCatch e⇩1 h⇩0 l⇩0 a h⇩1 l⇩1 D fs C e⇩2 V e⇩2' h⇩2 l⇩2)
have IH⇩1: "⋀W. fv e⇩1 ⊆ W ⟹ P ⊢ ⟨e⇩1,(h⇩0,l⇩0|`W)⟩ ⇒ ⟨Throw a,(h⇩1,l⇩1|`W)⟩"
and IH⇩2: "⋀W. fv e⇩2 ⊆ W ⟹ P ⊢ ⟨e⇩2,(h⇩1,l⇩1(V↦Addr a)|`W)⟩ ⇒ ⟨e⇩2',(h⇩2,l⇩2|`W)⟩"
and lookup: "h⇩1 a = Some(D, fs)" and subtype: "P ⊢ D ≼⇧* C" by fact+
have "fv (try e⇩1 catch(C V) e⇩2) ⊆ W" by fact
hence fv⇩1: "fv e⇩1 ⊆ W" and fv⇩2: "fv e⇩2 ⊆ insert V W" by auto
have IH⇩2': "P ⊢ ⟨e⇩2,(h⇩1,(l⇩1|`W)(V ↦ Addr a))⟩ ⇒ ⟨e⇩2',(h⇩2,l⇩2|`insert V W)⟩"
using IH⇩2[OF fv⇩2] fun_upd_restrict[of l⇩1 W] by simp
with eval_evals.TryCatch[OF IH⇩1[OF fv⇩1] _ subtype IH⇩2'] lookup
show ?case by fastforce
next
case TryThrow thus ?case by simp (blast intro: eval_evals.TryThrow)
next
case Nil thus ?case by (simp add: eval_evals.Nil)
next
case Cons thus ?case by simp (blast intro: eval_evals.Cons)
next
case ConsThrow thus ?case by simp (blast intro: eval_evals.ConsThrow)
qed
lemma eval_notfree_unchanged:
"P ⊢ ⟨e,(h,l)⟩ ⇒ ⟨e',(h',l')⟩ ⟹ (⋀V. V ∉ fv e ⟹ l' V = l V)"
and "P ⊢ ⟨es,(h,l)⟩ [⇒] ⟨es',(h',l')⟩ ⟹ (⋀V. V ∉ fvs es ⟹ l' V = l V)"
proof(induct rule:eval_evals_inducts)
case LAss thus ?case by(simp add:fun_upd_apply)
next
case Block thus ?case
by (simp only:fun_upd_apply split:if_splits) fastforce
next
case TryCatch thus ?case
by (simp only:fun_upd_apply split:if_splits) fastforce
qed simp_all
lemma eval_closed_lcl_unchanged:
"⟦ P ⊢ ⟨e,(h,l)⟩ ⇒ ⟨e',(h',l')⟩; fv e = {} ⟧ ⟹ l' = l"
by(fastforce dest:eval_notfree_unchanged simp add:fun_eq_iff [where 'b="val option"])
lemma list_eval_Throw:
assumes eval_e: "P ⊢ ⟨throw x,s⟩ ⇒ ⟨e',s'⟩"
shows "P ⊢ ⟨map Val vs @ throw x # es',s⟩ [⇒] ⟨map Val vs @ e' # es',s'⟩"
proof -
from eval_e
obtain a where e': "e' = Throw a"
by (cases) (auto dest!: eval_final)
{
fix es
have "⋀vs. es = map Val vs @ throw x # es'
⟹ P ⊢ ⟨es,s⟩[⇒]⟨map Val vs @ e' # es',s'⟩"
proof (induct es type: list)
case Nil thus ?case by simp
next
case (Cons e es vs)
have e_es: "e # es = map Val vs @ throw x # es'" by fact
show "P ⊢ ⟨e # es,s⟩ [⇒] ⟨map Val vs @ e' # es',s'⟩"
proof (cases vs)
case Nil
with e_es obtain "e=throw x" "es=es'" by simp
moreover from eval_e e'
have "P ⊢ ⟨throw x # es,s⟩ [⇒] ⟨Throw a # es,s'⟩"
by (iprover intro: ConsThrow)
ultimately show ?thesis using Nil e' by simp
next
case (Cons v vs')
have vs: "vs = v # vs'" by fact
with e_es obtain
e: "e=Val v" and es:"es= map Val vs' @ throw x # es'"
by simp
from e
have "P ⊢ ⟨e,s⟩ ⇒ ⟨Val v,s⟩"
by (iprover intro: eval_evals.Val)
moreover from es
have "P ⊢ ⟨es,s⟩ [⇒] ⟨map Val vs' @ e' # es',s'⟩"
by (rule Cons.hyps)
ultimately show
"P ⊢ ⟨e#es,s⟩ [⇒] ⟨map Val vs @ e' # es',s'⟩"
using vs by (auto intro: eval_evals.Cons)
qed
qed
}
thus ?thesis
by simp
qed
declare split_paired_All [simp del] split_paired_Ex [simp del]
text ‹The key lemma:›
lemma
assumes wf: "wwf_J_prog P"
shows extend_1_eval:
"P ⊢ ⟨e,s⟩ → ⟨e'',s''⟩ ⟹ (⋀s' e'. P ⊢ ⟨e'',s''⟩ ⇒ ⟨e',s'⟩ ⟹ P ⊢ ⟨e,s⟩ ⇒ ⟨e',s'⟩)"
and extend_1_evals:
"P ⊢ ⟨es,t⟩ [→] ⟨es'',t''⟩ ⟹ (⋀t' es'. P ⊢ ⟨es'',t''⟩ [⇒] ⟨es',t'⟩ ⟹ P ⊢ ⟨es,t⟩ [⇒] ⟨es',t'⟩)"
proof (induct rule: red_reds.inducts)
case (RedCall s a C fs M Ts T pns body D vs s' e')
have "P ⊢ ⟨addr a,s⟩ ⇒ ⟨addr a,s⟩" by (rule eval_evals.intros)
moreover
have finals: "finals(map Val vs)" by simp
obtain h⇩2 l⇩2 where s: "s = (h⇩2,l⇩2)" by (cases s)
with finals have "P ⊢ ⟨map Val vs,s⟩ [⇒] ⟨map Val vs,(h⇩2,l⇩2)⟩"
by (iprover intro: eval_finalsId)
moreover from s have "h⇩2 a = Some (C, fs)" using RedCall by simp
moreover have "method": "P ⊢ C sees M: Ts→T = (pns, body) in D" by fact
moreover have same_len⇩1: "length Ts = length pns"
and this_distinct: "this ∉ set pns" and fv: "fv body ⊆ {this} ∪ set pns"
using "method" wf by (fastforce dest!:sees_wf_mdecl simp:wf_mdecl_def)+
have same_len: "length vs = length pns" by fact
moreover
obtain l⇩2' where l⇩2': "l⇩2' = [this↦Addr a,pns[↦]vs]" by simp
moreover
obtain h⇩3 l⇩3 where s': "s' = (h⇩3,l⇩3)" by (cases s')
have eval_blocks:
"P ⊢ ⟨blocks (this # pns, Class D # Ts, Addr a # vs, body),s⟩ ⇒ ⟨e',s'⟩" by fact
hence id: "l⇩3 = l⇩2" using fv s s' same_len⇩1 same_len
by(fastforce elim: eval_closed_lcl_unchanged)
from eval_blocks obtain l⇩3' where "P ⊢ ⟨body,(h⇩2,l⇩2')⟩ ⇒ ⟨e',(h⇩3,l⇩3')⟩"
proof -
from same_len⇩1 have "length(this#pns) = length(Class D#Ts)" by simp
moreover from same_len⇩1 same_len
have "length (this#pns) = length (Addr a#vs)" by simp
moreover from eval_blocks
have "P ⊢ ⟨blocks (this#pns,Class D#Ts,Addr a#vs,body),(h⇩2,l⇩2)⟩
⇒⟨e',(h⇩3,l⇩3)⟩" using s s' by simp
ultimately obtain l''
where "P ⊢ ⟨body,(h⇩2,l⇩2(this # pns[↦]Addr a # vs))⟩⇒⟨e',(h⇩3, l'')⟩"
by (blast dest:blocksEval)
from eval_restrict_lcl[OF wf this fv] this_distinct same_len⇩1 same_len
have "P ⊢ ⟨body,(h⇩2,[this # pns[↦]Addr a # vs])⟩ ⇒
⟨e',(h⇩3, l''|`(set(this#pns)))⟩"
by(simp add:subset_insert_iff insert_Diff_if)
thus ?thesis by(fastforce intro!:that simp add: l⇩2')
qed
ultimately
have "P ⊢ ⟨(addr a)∙M(map Val vs),s⟩ ⇒ ⟨e',(h⇩3,l⇩2)⟩" by (rule Call)
with s' id show ?case by simp
next
case RedNew
thus ?case
by (iprover elim: eval_cases intro: eval_evals.intros)
next
case RedNewFail
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case (CastRed e s e'' s'' C s' e')
thus ?case
by(cases s, cases s') (erule eval_cases, auto intro: eval_evals.intros)
next
case RedCastNull
thus ?case
by (iprover elim: eval_cases intro: eval_evals.intros)
next
case (RedCast s a D fs C s'' e'')
thus ?case
by (cases s) (auto elim: eval_cases intro: eval_evals.intros)
next
case (RedCastFail s a D fs C s'' e'')
thus ?case
by (cases s) (auto elim!: eval_cases intro: eval_evals.intros)
next
case (BinOpRed1 e s e' s' bop e⇩2 s'' e')
thus ?case
by (cases s'')(erule eval_cases,auto intro: eval_evals.intros)
next
case BinOpRed2
thus ?case
by (fastforce elim!: eval_cases intro: eval_evals.intros eval_finalId)
next
case RedBinOp
thus ?case
by (iprover elim: eval_cases intro: eval_evals.intros)
next
case (RedVar s V v s' e')
thus ?case
by (cases s)(fastforce elim: eval_cases intro: eval_evals.intros)
next
case (LAssRed e s e' s' V s'')
thus ?case
by (cases s'')(erule eval_cases,auto intro: eval_evals.intros)
next
case RedLAss
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case (FAccRed e s e' s' F D s'')
thus ?case
by (cases s'')(erule eval_cases,auto intro: eval_evals.intros)
next
case (RedFAcc s a C fs F D v s' e')
thus ?case
by (cases s)(fastforce elim: eval_cases intro: eval_evals.intros)
next
case RedFAccNull
thus ?case
by (fastforce elim!: eval_cases intro: eval_evals.intros)
next
case (FAssRed1 e s e' s'' F D e⇩2 s' e')
thus ?case
by (cases s')(erule eval_cases, auto intro: eval_evals.intros)
next
case (FAssRed2 e s e' s'' v F D s' e')
thus ?case
by (cases s)
(fastforce elim!: eval_cases intro: eval_evals.intros eval_finalId)
next
case RedFAss
thus ?case
by (fastforce elim!: eval_cases intro: eval_evals.intros)
next
case RedFAssNull
thus ?case
by (fastforce elim!: eval_cases intro: eval_evals.intros)
next
case CallObj
thus ?case
by (fastforce elim!: eval_cases intro: eval_evals.intros)
next
case CallParams
thus ?case
by (fastforce elim!: eval_cases intro: eval_evals.intros eval_finalId)
next
case RedCallNull
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros eval_finalsId)
next
case InitBlockRed
thus ?case
by (fastforce elim!: eval_cases intro: eval_evals.intros eval_finalId
simp add: map_upd_triv fun_upd_same)
next
case (RedInitBlock V T v u s s' e')
have "P ⊢ ⟨Val u,s⟩ ⇒ ⟨e',s'⟩" by fact
then obtain s': "s'=s" and e': "e'=Val u" by cases simp
obtain h l where s: "s=(h,l)" by (cases s)
have "P ⊢ ⟨{V:T :=Val v; Val u},(h,l)⟩ ⇒ ⟨Val u,(h, (l(V↦v))(V:=l V))⟩"
by (fastforce intro!: eval_evals.intros)
thus "P ⊢ ⟨{V:T := Val v; Val u},s⟩ ⇒ ⟨e',s'⟩"
using s s' e' by simp
next
case BlockRedNone
thus ?case
by (fastforce elim!: eval_cases intro: eval_evals.intros
simp add: fun_upd_same fun_upd_idem)
next
case BlockRedSome
thus ?case
by (fastforce elim!: eval_cases intro: eval_evals.intros
simp add: fun_upd_same fun_upd_idem)
next
case (RedBlock V T v s s' e')
have "P ⊢ ⟨Val v,s⟩ ⇒ ⟨e',s'⟩" by fact
then obtain s': "s'=s" and e': "e'=Val v"
by cases simp
obtain h l where s: "s=(h,l)" by (cases s)
have "P ⊢ ⟨Val v,(h,l(V:=None))⟩ ⇒ ⟨Val v,(h,l(V:=None))⟩"
by (rule eval_evals.intros)
hence "P ⊢ ⟨{V:T;Val v},(h,l)⟩ ⇒ ⟨Val v,(h,(l(V:=None))(V:=l V))⟩"
by (rule eval_evals.Block)
thus "P ⊢ ⟨{V:T; Val v},s⟩ ⇒ ⟨e',s'⟩"
using s s' e'
by simp
next
case SeqRed
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case RedSeq
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case CondRed
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case RedCondT
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case RedCondF
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case RedWhile
thus ?case
by (auto simp add: unfold_while intro:eval_evals.intros elim:eval_cases)
next
case ThrowRed
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case RedThrowNull
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case (TryRed e s e' s' C V e⇩2 s'' e')
thus ?case
by (cases s, cases s'', auto elim!: eval_cases intro: eval_evals.intros)
next
case RedTry
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case RedTryCatch
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case (RedTryFail s a D fs C V e⇩2 s' e')
thus ?case
by (cases s)(auto elim!: eval_cases intro: eval_evals.intros)
next
case ListRed1
thus ?case
by (fastforce elim: evals_cases intro: eval_evals.intros)
next
case ListRed2
thus ?case
by (fastforce elim!: evals_cases eval_cases
intro: eval_evals.intros eval_finalId)
next
case CastThrow
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case BinOpThrow1
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case BinOpThrow2
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case LAssThrow
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case FAccThrow
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case FAssThrow1
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case FAssThrow2
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case CallThrowObj
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case (CallThrowParams es vs e es' v M s s' e')
have "P ⊢ ⟨Val v,s⟩ ⇒ ⟨Val v,s⟩" by (rule eval_evals.intros)
moreover
have es: "es = map Val vs @ throw e # es'" by fact
have eval_e: "P ⊢ ⟨throw e,s⟩ ⇒ ⟨e',s'⟩" by fact
then obtain xa where e': "e' = Throw xa" by (cases) (auto dest!: eval_final)
with list_eval_Throw [OF eval_e] es
have "P ⊢ ⟨es,s⟩ [⇒] ⟨map Val vs @ Throw xa # es',s'⟩" by simp
ultimately have "P ⊢ ⟨Val v∙M(es),s⟩ ⇒ ⟨Throw xa,s'⟩"
by (rule eval_evals.CallParamsThrow)
thus ?case using e' by simp
next
case (InitBlockThrow V T v a s s' e')
have "P ⊢ ⟨Throw a,s⟩ ⇒ ⟨e',s'⟩" by fact
then obtain s': "s' = s" and e': "e' = Throw a"
by cases (auto elim!:eval_cases)
obtain h l where s: "s = (h,l)" by (cases s)
have "P ⊢ ⟨{V:T :=Val v; Throw a},(h,l)⟩ ⇒ ⟨Throw a, (h, (l(V↦v))(V:=l V))⟩"
by(fastforce intro:eval_evals.intros)
thus "P ⊢ ⟨{V:T := Val v; Throw a},s⟩ ⇒ ⟨e',s'⟩" using s s' e' by simp
next
case (BlockThrow V T a s s' e')
have "P ⊢ ⟨Throw a, s⟩ ⇒ ⟨e',s'⟩" by fact
then obtain s': "s' = s" and e': "e' = Throw a"
by cases (auto elim!:eval_cases)
obtain h l where s: "s=(h,l)" by (cases s)
have "P ⊢ ⟨Throw a, (h,l(V:=None))⟩ ⇒ ⟨Throw a, (h,l(V:=None))⟩"
by (simp add:eval_evals.intros eval_finalId)
hence "P⊢⟨{V:T;Throw a},(h,l)⟩⇒⟨Throw a, (h,(l(V:=None))(V:=l V))⟩"
by (rule eval_evals.Block)
thus "P ⊢ ⟨{V:T; Throw a},s⟩ ⇒ ⟨e',s'⟩" using s s' e' by simp
next
case SeqThrow
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case CondThrow
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
next
case ThrowThrow
thus ?case
by (fastforce elim: eval_cases intro: eval_evals.intros)
qed
declare split_paired_All [simp] split_paired_Ex [simp]
text ‹Its extension to ‹→*›:›
lemma extend_eval:
assumes wf: "wwf_J_prog P"
and reds: "P ⊢ ⟨e,s⟩ →* ⟨e'',s''⟩" and eval_rest: "P ⊢ ⟨e'',s''⟩ ⇒ ⟨e',s'⟩"
shows "P ⊢ ⟨e,s⟩ ⇒ ⟨e',s'⟩"
using reds eval_rest
apply (induct rule: converse_rtrancl_induct2)
apply simp
apply simp
apply (rule extend_1_eval)
apply (rule wf)
apply assumption
apply assumption
done
lemma extend_evals:
assumes wf: "wwf_J_prog P"
and reds: "P ⊢ ⟨es,s⟩ [→]* ⟨es'',s''⟩" and eval_rest: "P ⊢ ⟨es'',s''⟩ [⇒] ⟨es',s'⟩"
shows "P ⊢ ⟨es,s⟩ [⇒] ⟨es',s'⟩"
using reds eval_rest
apply (induct rule: converse_rtrancl_induct2)
apply simp
apply simp
apply (rule extend_1_evals)
apply (rule wf)
apply assumption
apply assumption
done
text ‹Finally, small step semantics can be simulated by big step semantics:
›
theorem
assumes wf: "wwf_J_prog P"
shows small_by_big: "⟦P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩; final e'⟧ ⟹ P ⊢ ⟨e,s⟩ ⇒ ⟨e',s'⟩"
and "⟦P ⊢ ⟨es,s⟩ [→]* ⟨es',s'⟩; finals es'⟧ ⟹ P ⊢ ⟨es,s⟩ [⇒] ⟨es',s'⟩"
proof -
note wf
moreover assume "P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩"
moreover assume "final e'"
then have "P ⊢ ⟨e',s'⟩ ⇒ ⟨e',s'⟩"
by (rule eval_finalId)
ultimately show "P ⊢ ⟨e,s⟩⇒⟨e',s'⟩"
by (rule extend_eval)
next
note wf
moreover assume "P ⊢ ⟨es,s⟩ [→]* ⟨es',s'⟩"
moreover assume "finals es'"
then have "P ⊢ ⟨es',s'⟩ [⇒] ⟨es',s'⟩"
by (rule eval_finalsId)
ultimately show "P ⊢ ⟨es,s⟩ [⇒] ⟨es',s'⟩"
by (rule extend_evals)
qed
subsection "Equivalence"
text‹And now, the crowning achievement:›
corollary big_iff_small:
"wwf_J_prog P ⟹
P ⊢ ⟨e,s⟩ ⇒ ⟨e',s'⟩ = (P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩ ∧ final e')"
by(blast dest: big_by_small eval_final small_by_big)
end
Theory WellType
section ‹Well-typedness of Jinja expressions›
theory WellType
imports "../Common/Objects" Expr
begin
type_synonym
env = "vname ⇀ ty"
inductive
WT :: "[J_prog,env, expr , ty ] ⇒ bool"
("_,_ ⊢ _ :: _" [51,51,51]50)
and WTs :: "[J_prog,env, expr list, ty list] ⇒ bool"
("_,_ ⊢ _ [::] _" [51,51,51]50)
for P :: J_prog
where
WTNew:
"is_class P C ⟹
P,E ⊢ new C :: Class C"
| WTCast:
"⟦ P,E ⊢ e :: Class D; is_class P C; P ⊢ C ≼⇧* D ∨ P ⊢ D ≼⇧* C ⟧
⟹ P,E ⊢ Cast C e :: Class C"
| WTVal:
"typeof v = Some T ⟹
P,E ⊢ Val v :: T"
| WTVar:
"E V = Some T ⟹
P,E ⊢ Var V :: T"
| WTBinOpEq:
"⟦ P,E ⊢ e⇩1 :: T⇩1; P,E ⊢ e⇩2 :: T⇩2; P ⊢ T⇩1 ≤ T⇩2 ∨ P ⊢ T⇩2 ≤ T⇩1 ⟧
⟹ P,E ⊢ e⇩1 «Eq» e⇩2 :: Boolean"
| WTBinOpAdd:
"⟦ P,E ⊢ e⇩1 :: Integer; P,E ⊢ e⇩2 :: Integer ⟧
⟹ P,E ⊢ e⇩1 «Add» e⇩2 :: Integer"
| WTLAss:
"⟦ E V = Some T; P,E ⊢ e :: T'; P ⊢ T' ≤ T; V ≠ this ⟧
⟹ P,E ⊢ V:=e :: Void"
| WTFAcc:
"⟦ P,E ⊢ e :: Class C; P ⊢ C sees F:T in D ⟧
⟹ P,E ⊢ e∙F{D} :: T"
| WTFAss:
"⟦ P,E ⊢ e⇩1 :: Class C; P ⊢ C sees F:T in D; P,E ⊢ e⇩2 :: T'; P ⊢ T' ≤ T ⟧
⟹ P,E ⊢ e⇩1∙F{D}:=e⇩2 :: Void"
| WTCall:
"⟦ P,E ⊢ e :: Class C; P ⊢ C sees M:Ts → T = (pns,body) in D;
P,E ⊢ es [::] Ts'; P ⊢ Ts' [≤] Ts ⟧
⟹ P,E ⊢ e∙M(es) :: T"
| WTBlock:
"⟦ is_type P T; P,E(V ↦ T) ⊢ e :: T' ⟧
⟹ P,E ⊢ {V:T; e} :: T'"
| WTSeq:
"⟦ P,E ⊢ e⇩1::T⇩1; P,E ⊢ e⇩2::T⇩2 ⟧
⟹ P,E ⊢ e⇩1;;e⇩2 :: T⇩2"
| WTCond:
"⟦ P,E ⊢ e :: Boolean; P,E ⊢ e⇩1::T⇩1; P,E ⊢ e⇩2::T⇩2;
P ⊢ T⇩1 ≤ T⇩2 ∨ P ⊢ T⇩2 ≤ T⇩1; P ⊢ T⇩1 ≤ T⇩2 ⟶ T = T⇩2; P ⊢ T⇩2 ≤ T⇩1 ⟶ T = T⇩1 ⟧
⟹ P,E ⊢ if (e) e⇩1 else e⇩2 :: T"
| WTWhile:
"⟦ P,E ⊢ e :: Boolean; P,E ⊢ c::T ⟧
⟹ P,E ⊢ while (e) c :: Void"
| WTThrow:
"P,E ⊢ e :: Class C ⟹
P,E ⊢ throw e :: Void"
| WTTry:
"⟦ P,E ⊢ e⇩1 :: T; P,E(V ↦ Class C) ⊢ e⇩2 :: T; is_class P C ⟧
⟹ P,E ⊢ try e⇩1 catch(C V) e⇩2 :: T"
| WTNil:
"P,E ⊢ [] [::] []"
| WTCons:
"⟦ P,E ⊢ e :: T; P,E ⊢ es [::] Ts ⟧
⟹ P,E ⊢ e#es [::] T#Ts"
declare WT_WTs.intros[intro!]
lemmas WT_WTs_induct = WT_WTs.induct [split_format (complete)]
and WT_WTs_inducts = WT_WTs.inducts [split_format (complete)]
lemma [iff]: "(P,E ⊢ [] [::] Ts) = (Ts = [])"
apply(rule iffI)
apply (auto elim: WTs.cases)
done
lemma [iff]: "(P,E ⊢ e#es [::] T#Ts) = (P,E ⊢ e :: T ∧ P,E ⊢ es [::] Ts)"
apply(rule iffI)
apply (auto elim: WTs.cases)
done
lemma [iff]: "(P,E ⊢ (e#es) [::] Ts) =
(∃U Us. Ts = U#Us ∧ P,E ⊢ e :: U ∧ P,E ⊢ es [::] Us)"
apply(rule iffI)
apply (auto elim: WTs.cases)
done
lemma [iff]: "⋀Ts. (P,E ⊢ es⇩1 @ es⇩2 [::] Ts) =
(∃Ts⇩1 Ts⇩2. Ts = Ts⇩1 @ Ts⇩2 ∧ P,E ⊢ es⇩1 [::] Ts⇩1 ∧ P,E ⊢ es⇩2[::]Ts⇩2)"
apply(induct es⇩1 type:list)
apply simp
apply clarsimp
apply(erule thin_rl)
apply (rule iffI)
apply clarsimp
apply(rule exI)+
apply(rule conjI)
prefer 2 apply blast
apply simp
apply fastforce
done
lemma [iff]: "P,E ⊢ Val v :: T = (typeof v = Some T)"
apply(rule iffI)
apply (auto elim: WT.cases)
done
lemma [iff]: "P,E ⊢ Var V :: T = (E V = Some T)"
apply(rule iffI)
apply (auto elim: WT.cases)
done
lemma [iff]: "P,E ⊢ e⇩1;;e⇩2 :: T⇩2 = (∃T⇩1. P,E ⊢ e⇩1::T⇩1 ∧ P,E ⊢ e⇩2::T⇩2)"
apply(rule iffI)
apply (auto elim: WT.cases)
done
lemma [iff]: "(P,E ⊢ {V:T; e} :: T') = (is_type P T ∧ P,E(V↦T) ⊢ e :: T')"
apply(rule iffI)
apply (auto elim: WT.cases)
done
inductive_cases WT_elim_cases[elim!]:
"P,E ⊢ V :=e :: T"
"P,E ⊢ if (e) e⇩1 else e⇩2 :: T"
"P,E ⊢ while (e) c :: T"
"P,E ⊢ throw e :: T"
"P,E ⊢ try e⇩1 catch(C V) e⇩2 :: T"
"P,E ⊢ Cast D e :: T"
"P,E ⊢ a∙F{D} :: T"
"P,E ⊢ a∙F{D} := v :: T"
"P,E ⊢ e⇩1 «bop» e⇩2 :: T"
"P,E ⊢ new C :: T"
"P,E ⊢ e∙M(ps) :: T"
lemma wt_env_mono:
"P,E ⊢ e :: T ⟹ (⋀E'. E ⊆⇩m E' ⟹ P,E' ⊢ e :: T)" and
"P,E ⊢ es [::] Ts ⟹ (⋀E'. E ⊆⇩m E' ⟹ P,E' ⊢ es [::] Ts)"
apply(induct rule: WT_WTs_inducts)
apply(simp add: WTNew)
apply(fastforce simp: WTCast)
apply(fastforce simp: WTVal)
apply(simp add: WTVar map_le_def dom_def)
apply(fastforce simp: WTBinOpEq)
apply(fastforce simp: WTBinOpAdd)
apply(force simp:map_le_def)
apply(fastforce simp: WTFAcc)
apply(fastforce simp: WTFAss del:WT_WTs.intros WT_elim_cases)
apply(fastforce simp: WTCall)
apply(fastforce simp: map_le_def WTBlock)
apply(fastforce simp: WTSeq)
apply(fastforce simp: WTCond)
apply(fastforce simp: WTWhile)
apply(fastforce simp: WTThrow)
apply(fastforce simp: WTTry map_le_def dom_def)
apply(simp add: WTNil)
apply(simp add: WTCons)
done
lemma WT_fv: "P,E ⊢ e :: T ⟹ fv e ⊆ dom E"
and "P,E ⊢ es [::] Ts ⟹ fvs es ⊆ dom E"
apply(induct rule:WT_WTs.inducts)
apply(simp_all del: fun_upd_apply)
apply fast+
done
end
Theory WellTypeRT
section ‹Runtime Well-typedness›
theory WellTypeRT
imports WellType
begin
inductive
WTrt :: "J_prog ⇒ heap ⇒ env ⇒ expr ⇒ ty ⇒ bool"
and WTrts :: "J_prog ⇒ heap ⇒ env ⇒ expr list ⇒ ty list ⇒ bool"
and WTrt2 :: "[J_prog,env,heap,expr,ty] ⇒ bool"
("_,_,_ ⊢ _ : _" [51,51,51]50)
and WTrts2 :: "[J_prog,env,heap,expr list, ty list] ⇒ bool"
("_,_,_ ⊢ _ [:] _" [51,51,51]50)
for P :: J_prog and h :: heap
where
"P,E,h ⊢ e : T ≡ WTrt P h E e T"
| "P,E,h ⊢ es[:]Ts ≡ WTrts P h E es Ts"
| WTrtNew:
"is_class P C ⟹
P,E,h ⊢ new C : Class C"
| WTrtCast:
"⟦ P,E,h ⊢ e : T; is_refT T; is_class P C ⟧
⟹ P,E,h ⊢ Cast C e : Class C"
| WTrtVal:
"typeof⇘h⇙ v = Some T ⟹
P,E,h ⊢ Val v : T"
| WTrtVar:
"E V = Some T ⟹
P,E,h ⊢ Var V : T"
| WTrtBinOpEq:
"⟦ P,E,h ⊢ e⇩1 : T⇩1; P,E,h ⊢ e⇩2 : T⇩2 ⟧
⟹ P,E,h ⊢ e⇩1 «Eq» e⇩2 : Boolean"
| WTrtBinOpAdd:
"⟦ P,E,h ⊢ e⇩1 : Integer; P,E,h ⊢ e⇩2 : Integer ⟧
⟹ P,E,h ⊢ e⇩1 «Add» e⇩2 : Integer"
| WTrtLAss:
"⟦ E V = Some T; P,E,h ⊢ e : T'; P ⊢ T' ≤ T ⟧
⟹ P,E,h ⊢ V:=e : Void"
| WTrtFAcc:
"⟦ P,E,h ⊢ e : Class C; P ⊢ C has F:T in D ⟧ ⟹
P,E,h ⊢ e∙F{D} : T"
| WTrtFAccNT:
"P,E,h ⊢ e : NT ⟹
P,E,h ⊢ e∙F{D} : T"
| WTrtFAss:
"⟦ P,E,h ⊢ e⇩1 : Class C; P ⊢ C has F:T in D; P,E,h ⊢ e⇩2 : T⇩2; P ⊢ T⇩2 ≤ T ⟧
⟹ P,E,h ⊢ e⇩1∙F{D}:=e⇩2 : Void"
| WTrtFAssNT:
"⟦ P,E,h ⊢ e⇩1:NT; P,E,h ⊢ e⇩2 : T⇩2 ⟧
⟹ P,E,h ⊢ e⇩1∙F{D}:=e⇩2 : Void"
| WTrtCall:
"⟦ P,E,h ⊢ e : Class C; P ⊢ C sees M:Ts → T = (pns,body) in D;
P,E,h ⊢ es [:] Ts'; P ⊢ Ts' [≤] Ts ⟧
⟹ P,E,h ⊢ e∙M(es) : T"
| WTrtCallNT:
"⟦ P,E,h ⊢ e : NT; P,E,h ⊢ es [:] Ts ⟧
⟹ P,E,h ⊢ e∙M(es) : T"
| WTrtBlock:
"P,E(V↦T),h ⊢ e : T' ⟹
P,E,h ⊢ {V:T; e} : T'"
| WTrtSeq:
"⟦ P,E,h ⊢ e⇩1:T⇩1; P,E,h ⊢ e⇩2:T⇩2 ⟧
⟹ P,E,h ⊢ e⇩1;;e⇩2 : T⇩2"
| WTrtCond:
"⟦ P,E,h ⊢ e : Boolean; P,E,h ⊢ e⇩1:T⇩1; P,E,h ⊢ e⇩2:T⇩2;
P ⊢ T⇩1 ≤ T⇩2 ∨ P ⊢ T⇩2 ≤ T⇩1; P ⊢ T⇩1 ≤ T⇩2 ⟶ T = T⇩2; P ⊢ T⇩2 ≤ T⇩1 ⟶ T = T⇩1 ⟧
⟹ P,E,h ⊢ if (e) e⇩1 else e⇩2 : T"
| WTrtWhile:
"⟦ P,E,h ⊢ e : Boolean; P,E,h ⊢ c:T ⟧
⟹ P,E,h ⊢ while(e) c : Void"
| WTrtThrow:
"⟦ P,E,h ⊢ e : T⇩r; is_refT T⇩r ⟧ ⟹
P,E,h ⊢ throw e : T"
| WTrtTry:
"⟦ P,E,h ⊢ e⇩1 : T⇩1; P,E(V ↦ Class C),h ⊢ e⇩2 : T⇩2; P ⊢ T⇩1 ≤ T⇩2 ⟧
⟹ P,E,h ⊢ try e⇩1 catch(C V) e⇩2 : T⇩2"
| WTrtNil:
"P,E,h ⊢ [] [:] []"
| WTrtCons:
"⟦ P,E,h ⊢ e : T; P,E,h ⊢ es [:] Ts ⟧
⟹ P,E,h ⊢ e#es [:] T#Ts"
declare WTrt_WTrts.intros[intro!] WTrtNil[iff]
declare
WTrtFAcc[rule del] WTrtFAccNT[rule del]
WTrtFAss[rule del] WTrtFAssNT[rule del]
WTrtCall[rule del] WTrtCallNT[rule del]
lemmas WTrt_induct = WTrt_WTrts.induct [split_format (complete)]
and WTrt_inducts = WTrt_WTrts.inducts [split_format (complete)]
subsection‹Easy consequences›
lemma [iff]: "(P,E,h ⊢ [] [:] Ts) = (Ts = [])"
apply(rule iffI)
apply (auto elim: WTrts.cases)
done
lemma [iff]: "(P,E,h ⊢ e#es [:] T#Ts) = (P,E,h ⊢ e : T ∧ P,E,h ⊢ es [:] Ts)"
apply(rule iffI)
apply (auto elim: WTrts.cases)
done
lemma [iff]: "(P,E,h ⊢ (e#es) [:] Ts) =
(∃U Us. Ts = U#Us ∧ P,E,h ⊢ e : U ∧ P,E,h ⊢ es [:] Us)"
apply(rule iffI)
apply (auto elim: WTrts.cases)
done
lemma [simp]: "∀Ts. (P,E,h ⊢ es⇩1 @ es⇩2 [:] Ts) =
(∃Ts⇩1 Ts⇩2. Ts = Ts⇩1 @ Ts⇩2 ∧ P,E,h ⊢ es⇩1 [:] Ts⇩1 & P,E,h ⊢ es⇩2[:]Ts⇩2)"
apply(induct_tac es⇩1)
apply simp
apply clarsimp
apply(erule thin_rl)
apply (rule iffI)
apply clarsimp
apply(rule exI)+
apply(rule conjI)
prefer 2 apply blast
apply simp
apply fastforce
done
lemma [iff]: "P,E,h ⊢ Val v : T = (typeof⇘h⇙ v = Some T)"
apply(rule iffI)
apply (auto elim: WTrt.cases)
done
lemma [iff]: "P,E,h ⊢ Var v : T = (E v = Some T)"
apply(rule iffI)
apply (auto elim: WTrt.cases)
done
lemma [iff]: "P,E,h ⊢ e⇩1;;e⇩2 : T⇩2 = (∃T⇩1. P,E,h ⊢ e⇩1:T⇩1 ∧ P,E,h ⊢ e⇩2:T⇩2)"
apply(rule iffI)
apply (auto elim: WTrt.cases)
done
lemma [iff]: "P,E,h ⊢ {V:T; e} : T' = (P,E(V↦T),h ⊢ e : T')"
apply(rule iffI)
apply (auto elim: WTrt.cases)
done
inductive_cases WTrt_elim_cases[elim!]:
"P,E,h ⊢ v :=e : T"
"P,E,h ⊢ if (e) e⇩1 else e⇩2 : T"
"P,E,h ⊢ while(e) c : T"
"P,E,h ⊢ throw e : T"
"P,E,h ⊢ try e⇩1 catch(C V) e⇩2 : T"
"P,E,h ⊢ Cast D e : T"
"P,E,h ⊢ e∙F{D} : T"
"P,E,h ⊢ e∙F{D} := v : T"
"P,E,h ⊢ e⇩1 «bop» e⇩2 : T"
"P,E,h ⊢ new C : T"
"P,E,h ⊢ e∙M{D}(es) : T"
subsection‹Some interesting lemmas›
lemma WTrts_Val[simp]:
"⋀Ts. (P,E,h ⊢ map Val vs [:] Ts) = (map (typeof⇘h⇙) vs = map Some Ts)"
apply(induct vs)
apply simp
apply(case_tac Ts)
apply simp
apply simp
done
lemma WTrts_same_length: "⋀Ts. P,E,h ⊢ es [:] Ts ⟹ length es = length Ts"
by(induct es type:list)auto
lemma WTrt_env_mono:
"P,E,h ⊢ e : T ⟹ (⋀E'. E ⊆⇩m E' ⟹ P,E',h ⊢ e : T)" and
"P,E,h ⊢ es [:] Ts ⟹ (⋀E'. E ⊆⇩m E' ⟹ P,E',h ⊢ es [:] Ts)"
apply(induct rule: WTrt_inducts)
apply(simp add: WTrtNew)
apply(fastforce simp: WTrtCast)
apply(fastforce simp: WTrtVal)
apply(simp add: WTrtVar map_le_def dom_def)
apply(fastforce simp add: WTrtBinOpEq)
apply(fastforce simp add: WTrtBinOpAdd)
apply(force simp: map_le_def)
apply(fastforce simp: WTrtFAcc)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss)
apply(fastforce simp: WTrtFAssNT)
apply(fastforce simp: WTrtCall)
apply(fastforce simp: WTrtCallNT)
apply(simp add: WTrtNil)
apply(simp add: WTrtCons)
apply(fastforce simp: map_le_def)
apply(fastforce)
apply(fastforce simp: WTrtSeq)
apply(fastforce simp: WTrtWhile)
apply(fastforce simp: WTrtThrow)
apply(auto simp: WTrtTry map_le_def dom_def)
done
lemma WTrt_hext_mono: "P,E,h ⊢ e : T ⟹ h ⊴ h' ⟹ P,E,h' ⊢ e : T"
and WTrts_hext_mono: "P,E,h ⊢ es [:] Ts ⟹ h ⊴ h' ⟹ P,E,h' ⊢ es [:] Ts"
apply(induct rule: WTrt_inducts)
apply(simp add: WTrtNew)
apply(fastforce simp: WTrtCast)
apply(fastforce simp: WTrtVal dest:hext_typeof_mono)
apply(simp add: WTrtVar)
apply(fastforce simp add: WTrtBinOpEq)
apply(fastforce simp add: WTrtBinOpAdd)
apply(fastforce simp add: WTrtLAss)
apply(fast intro: WTrtFAcc)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtFAssNT)
apply(fastforce simp: WTrtCall)
apply(fastforce simp: WTrtCallNT)
apply(fastforce)
apply(fastforce simp add: WTrtSeq)
apply(fastforce simp add: WTrtCond)
apply(fastforce simp add: WTrtWhile)
apply(fastforce simp add: WTrtThrow)
apply(fastforce simp: WTrtTry)
apply(simp add: WTrtNil)
apply(simp add: WTrtCons)
done
lemma WT_implies_WTrt: "P,E ⊢ e :: T ⟹ P,E,h ⊢ e : T"
and WTs_implies_WTrts: "P,E ⊢ es [::] Ts ⟹ P,E,h ⊢ es [:] Ts"
apply(induct rule: WT_WTs_inducts)
apply fast
apply (fast)
apply(fastforce dest:typeof_lit_typeof)
apply(simp)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(fastforce simp: WTrtFAcc has_visible_field)
apply(fastforce simp: WTrtFAss dest: has_visible_field)
apply(fastforce simp: WTrtCall)
apply(fastforce)
apply(fastforce)
apply(fastforce simp: WTrtCond)
apply(fastforce)
apply(fastforce)
apply(fastforce)
apply(simp)
apply(simp)
done
end
Theory DefAss
section ‹Definite assignment›
theory DefAss imports BigStep begin
subsection "Hypersets"
type_synonym 'a hyperset = "'a set option"
definition hyperUn :: "'a hyperset ⇒ 'a hyperset ⇒ 'a hyperset" (infixl "⊔" 65)
where
"A ⊔ B ≡ case A of None ⇒ None
| ⌊A⌋ ⇒ (case B of None ⇒ None | ⌊B⌋ ⇒ ⌊A ∪ B⌋)"
definition hyperInt :: "'a hyperset ⇒ 'a hyperset ⇒ 'a hyperset" (infixl "⊓" 70)
where
"A ⊓ B ≡ case A of None ⇒ B
| ⌊A⌋ ⇒ (case B of None ⇒ ⌊A⌋ | ⌊B⌋ ⇒ ⌊A ∩ B⌋)"
definition hyperDiff1 :: "'a hyperset ⇒ 'a ⇒ 'a hyperset" (infixl "⊖" 65)
where
"A ⊖ a ≡ case A of None ⇒ None | ⌊A⌋ ⇒ ⌊A - {a}⌋"
definition hyper_isin :: "'a ⇒ 'a hyperset ⇒ bool" (infix "∈∈" 50)
where
"a ∈∈ A ≡ case A of None ⇒ True | ⌊A⌋ ⇒ a ∈ A"
definition hyper_subset :: "'a hyperset ⇒ 'a hyperset ⇒ bool" (infix "⊑" 50)
where
"A ⊑ B ≡ case B of None ⇒ True
| ⌊B⌋ ⇒ (case A of None ⇒ False | ⌊A⌋ ⇒ A ⊆ B)"
lemmas hyperset_defs =
hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def
lemma [simp]: "⌊{}⌋ ⊔ A = A ∧ A ⊔ ⌊{}⌋ = A"
by(simp add:hyperset_defs)
lemma [simp]: "⌊A⌋ ⊔ ⌊B⌋ = ⌊A ∪ B⌋ ∧ ⌊A⌋ ⊖ a = ⌊A - {a}⌋"
by(simp add:hyperset_defs)
lemma [simp]: "None ⊔ A = None ∧ A ⊔ None = None"
by(simp add:hyperset_defs)
lemma [simp]: "a ∈∈ None ∧ None ⊖ a = None"
by(simp add:hyperset_defs)
lemma hyperUn_assoc: "(A ⊔ B) ⊔ C = A ⊔ (B ⊔ C)"
by(simp add:hyperset_defs Un_assoc)
lemma hyper_insert_comm: "A ⊔ ⌊{a}⌋ = ⌊{a}⌋ ⊔ A ∧ A ⊔ (⌊{a}⌋ ⊔ B) = ⌊{a}⌋ ⊔ (A ⊔ B)"
by(simp add:hyperset_defs)
subsection "Definite assignment"
primrec
𝒜 :: "'a exp ⇒ 'a hyperset"
and 𝒜s :: "'a exp list ⇒ 'a hyperset"
where
"𝒜 (new C) = ⌊{}⌋"
| "𝒜 (Cast C e) = 𝒜 e"
| "𝒜 (Val v) = ⌊{}⌋"
| "𝒜 (e⇩1 «bop» e⇩2) = 𝒜 e⇩1 ⊔ 𝒜 e⇩2"
| "𝒜 (Var V) = ⌊{}⌋"
| "𝒜 (LAss V e) = ⌊{V}⌋ ⊔ 𝒜 e"
| "𝒜 (e∙F{D}) = 𝒜 e"
| "𝒜 (e⇩1∙F{D}:=e⇩2) = 𝒜 e⇩1 ⊔ 𝒜 e⇩2"
| "𝒜 (e∙M(es)) = 𝒜 e ⊔ 𝒜s es"
| "𝒜 ({V:T; e}) = 𝒜 e ⊖ V"
| "𝒜 (e⇩1;;e⇩2) = 𝒜 e⇩1 ⊔ 𝒜 e⇩2"
| "𝒜 (if (e) e⇩1 else e⇩2) = 𝒜 e ⊔ (𝒜 e⇩1 ⊓ 𝒜 e⇩2)"
| "𝒜 (while (b) e) = 𝒜 b"
| "𝒜 (throw e) = None"
| "𝒜 (try e⇩1 catch(C V) e⇩2) = 𝒜 e⇩1 ⊓ (𝒜 e⇩2 ⊖ V)"
| "𝒜s ([]) = ⌊{}⌋"
| "𝒜s (e#es) = 𝒜 e ⊔ 𝒜s es"
primrec
𝒟 :: "'a exp ⇒ 'a hyperset ⇒ bool"
and 𝒟s :: "'a exp list ⇒ 'a hyperset ⇒ bool"
where
"𝒟 (new C) A = True"
| "𝒟 (Cast C e) A = 𝒟 e A"
| "𝒟 (Val v) A = True"
| "𝒟 (e⇩1 «bop» e⇩2) A = (𝒟 e⇩1 A ∧ 𝒟 e⇩2 (A ⊔ 𝒜 e⇩1))"
| "𝒟 (Var V) A = (V ∈∈ A)"
| "𝒟 (LAss V e) A = 𝒟 e A"
| "𝒟 (e∙F{D}) A = 𝒟 e A"
| "𝒟 (e⇩1∙F{D}:=e⇩2) A = (𝒟 e⇩1 A ∧ 𝒟 e⇩2 (A ⊔ 𝒜 e⇩1))"
| "𝒟 (e∙M(es)) A = (𝒟 e A ∧ 𝒟s es (A ⊔ 𝒜 e))"
| "𝒟 ({V:T; e}) A = 𝒟 e (A ⊖ V)"
| "𝒟 (e⇩1;;e⇩2) A = (𝒟 e⇩1 A ∧ 𝒟 e⇩2 (A ⊔ 𝒜 e⇩1))"
| "𝒟 (if (e) e⇩1 else e⇩2) A =
(𝒟 e A ∧ 𝒟 e⇩1 (A ⊔ 𝒜 e) ∧ 𝒟 e⇩2 (A ⊔ 𝒜 e))"
| "𝒟 (while (e) c) A = (𝒟 e A ∧ 𝒟 c (A ⊔ 𝒜 e))"
| "𝒟 (throw e) A = 𝒟 e A"
| "𝒟 (try e⇩1 catch(C V) e⇩2) A = (𝒟 e⇩1 A ∧ 𝒟 e⇩2 (A ⊔ ⌊{V}⌋))"
| "𝒟s ([]) A = True"
| "𝒟s (e#es) A = (𝒟 e A ∧ 𝒟s es (A ⊔ 𝒜 e))"
lemma As_map_Val[simp]: "𝒜s (map Val vs) = ⌊{}⌋"
by (induct vs) simp_all
lemma D_append[iff]: "⋀A. 𝒟s (es @ es') A = (𝒟s es A ∧ 𝒟s es' (A ⊔ 𝒜s es))"
by (induct es type:list) (auto simp:hyperUn_assoc)
lemma A_fv: "⋀A. 𝒜 e = ⌊A⌋ ⟹ A ⊆ fv e"
and "⋀A. 𝒜s es = ⌊A⌋ ⟹ A ⊆ fvs es"
apply(induct e and es rule: 𝒜.induct 𝒜s.induct)
apply (simp_all add:hyperset_defs)
apply blast+
done
lemma sqUn_lem: "A ⊑ A' ⟹ A ⊔ B ⊑ A' ⊔ B"
by(simp add:hyperset_defs) blast
lemma diff_lem: "A ⊑ A' ⟹ A ⊖ b ⊑ A' ⊖ b"
by(simp add:hyperset_defs) blast
lemma D_mono: "⋀A A'. A ⊑ A' ⟹ 𝒟 e A ⟹ 𝒟 (e::'a exp) A'"
and Ds_mono: "⋀A A'. A ⊑ A' ⟹ 𝒟s es A ⟹ 𝒟s (es::'a exp list) A'"
apply(induct e and es rule: 𝒟.induct 𝒟s.induct)
apply simp
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply (fastforce simp add:hyperset_defs)
apply simp
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:diff_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp apply (iprover dest:sqUn_lem)
apply simp
apply simp apply (iprover dest:sqUn_lem)
done
lemma D_mono': "𝒟 e A ⟹ A ⊑ A' ⟹ 𝒟 e A'"
and Ds_mono': "𝒟s es A ⟹ A ⊑ A' ⟹ 𝒟s es A'"
by(blast intro:D_mono, blast intro:Ds_mono)
end
Theory Conform
section ‹Conformance Relations for Type Soundness Proofs›
theory Conform
imports Exceptions
begin
definition conf :: "'m prog ⇒ heap ⇒ val ⇒ ty ⇒ bool" ("_,_ ⊢ _ :≤ _" [51,51,51,51] 50)
where
"P,h ⊢ v :≤ T ≡
∃T'. typeof⇘h⇙ v = Some T' ∧ P ⊢ T' ≤ T"
definition oconf :: "'m prog ⇒ heap ⇒ obj ⇒ bool" ("_,_ ⊢ _ √" [51,51,51] 50)
where
"P,h ⊢ obj √ ≡
let (C,fs) = obj in ∀F D T. P ⊢ C has F:T in D ⟶
(∃v. fs(F,D) = Some v ∧ P,h ⊢ v :≤ T)"
definition hconf :: "'m prog ⇒ heap ⇒ bool" ("_ ⊢ _ √" [51,51] 50)
where
"P ⊢ h √ ≡
(∀a obj. h a = Some obj ⟶ P,h ⊢ obj √) ∧ preallocated h"
definition lconf :: "'m prog ⇒ heap ⇒ (vname ⇀ val) ⇒ (vname ⇀ ty) ⇒ bool" ("_,_ ⊢ _ '(:≤') _" [51,51,51,51] 50)
where
"P,h ⊢ l (:≤) E ≡
∀V v. l V = Some v ⟶ (∃T. E V = Some T ∧ P,h ⊢ v :≤ T)"
abbreviation
confs :: "'m prog ⇒ heap ⇒ val list ⇒ ty list ⇒ bool"
("_,_ ⊢ _ [:≤] _" [51,51,51,51] 50) where
"P,h ⊢ vs [:≤] Ts ≡ list_all2 (conf P h) vs Ts"
subsection‹Value conformance ‹:≤››
lemma conf_Null [simp]: "P,h ⊢ Null :≤ T = P ⊢ NT ≤ T"
apply (unfold conf_def)
apply (simp (no_asm))
done
lemma typeof_conf[simp]: "typeof⇘h⇙ v = Some T ⟹ P,h ⊢ v :≤ T"
apply (unfold conf_def)
apply (induct v)
apply auto
done
lemma typeof_lit_conf[simp]: "typeof v = Some T ⟹ P,h ⊢ v :≤ T"
by (rule typeof_conf[OF typeof_lit_typeof])
lemma defval_conf[simp]: "P,h ⊢ default_val T :≤ T"
apply (unfold conf_def)
apply (cases T)
apply auto
done
lemma conf_upd_obj: "h a = Some(C,fs) ⟹ (P,h(a↦(C,fs')) ⊢ x :≤ T) = (P,h ⊢ x :≤ T)"
apply (unfold conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
done
lemma conf_widen: "P,h ⊢ v :≤ T ⟹ P ⊢ T ≤ T' ⟹ P,h ⊢ v :≤ T'"
apply (unfold conf_def)
apply (induct v)
apply (auto intro: widen_trans)
done
lemma conf_hext: "h ⊴ h' ⟹ P,h ⊢ v :≤ T ⟹ P,h' ⊢ v :≤ T"
apply (unfold conf_def)
apply (induct v)
apply (auto dest: hext_objD)
done
lemma conf_ClassD: "P,h ⊢ v :≤ Class C ⟹
v = Null ∨ (∃a obj T. v = Addr a ∧ h a = Some obj ∧ obj_ty obj = T ∧ P ⊢ T ≤ Class C)"
apply (unfold conf_def)
apply(induct "v")
apply(auto)
done
lemma conf_NT [iff]: "P,h ⊢ v :≤ NT = (v = Null)"
by (auto simp add: conf_def)
lemma non_npD: "⟦ v ≠ Null; P,h ⊢ v :≤ Class C ⟧
⟹ ∃a C' fs. v = Addr a ∧ h a = Some(C',fs) ∧ P ⊢ C' ≼⇧* C"
apply (drule conf_ClassD)
apply auto
done
subsection‹Value list conformance ‹[:≤]››
lemma confs_widens [trans]: "⟦P,h ⊢ vs [:≤] Ts; P ⊢ Ts [≤] Ts'⟧ ⟹ P,h ⊢ vs [:≤] Ts'"
apply (rule list_all2_trans)
apply (rule conf_widen, assumption, assumption)
apply assumption
apply assumption
done
lemma confs_rev: "P,h ⊢ rev s [:≤] t = (P,h ⊢ s [:≤] rev t)"
apply rule
apply (rule subst [OF list_all2_rev])
apply simp
apply (rule subst [OF list_all2_rev])
apply simp
done
lemma confs_conv_map:
"⋀Ts'. P,h ⊢ vs [:≤] Ts' = (∃Ts. map typeof⇘h⇙ vs = map Some Ts ∧ P ⊢ Ts [≤] Ts')"
apply(induct vs)
apply simp
apply(case_tac Ts')
apply(auto simp add:conf_def)
done
lemma confs_hext: "P,h ⊢ vs [:≤] Ts ⟹ h ⊴ h' ⟹ P,h' ⊢ vs [:≤] Ts"
by (erule list_all2_mono, erule conf_hext, assumption)
lemma confs_Cons2: "P,h ⊢ xs [:≤] y#ys = (∃z zs. xs = z#zs ∧ P,h ⊢ z :≤ y ∧ P,h ⊢ zs [:≤] ys)"
by (rule list_all2_Cons2)
subsection "Object conformance"
lemma oconf_hext: "P,h ⊢ obj √ ⟹ h ⊴ h' ⟹ P,h' ⊢ obj √"
apply (unfold oconf_def)
apply (fastforce elim:conf_hext)
done
lemma oconf_init_fields:
"P ⊢ C has_fields FDTs ⟹ P,h ⊢ (C, init_fields FDTs) √"
by(fastforce simp add: has_field_def oconf_def init_fields_def map_of_map
dest: has_fields_fun)
lemma oconf_fupd [intro?]:
"⟦ P ⊢ C has F:T in D; P,h ⊢ v :≤ T; P,h ⊢ (C,fs) √ ⟧
⟹ P,h ⊢ (C, fs((F,D)↦v)) √"
apply (unfold oconf_def has_field_def)
apply clarsimp
apply (drule (1) has_fields_fun)
apply (auto simp add: fun_upd_apply)
done
lemmas oconf_new = oconf_hext [OF _ hext_new]
lemmas oconf_upd_obj = oconf_hext [OF _ hext_upd_obj]
subsection "Heap conformance"
lemma hconfD: "⟦ P ⊢ h √; h a = Some obj ⟧ ⟹ P,h ⊢ obj √"
apply (unfold hconf_def)
apply (fast)
done
lemma hconf_new: "⟦ P ⊢ h √; h a = None; P,h ⊢ obj √ ⟧ ⟹ P ⊢ h(a↦obj) √"
by (unfold hconf_def) (auto intro: oconf_new preallocated_new)
lemma hconf_upd_obj: "⟦ P ⊢ h√; h a = Some(C,fs); P,h ⊢ (C,fs')√ ⟧ ⟹ P ⊢ h(a↦(C,fs'))√"
by (unfold hconf_def) (auto intro: oconf_upd_obj preallocated_upd_obj)
subsection "Local variable conformance"
lemma lconf_hext: "⟦ P,h ⊢ l (:≤) E; h ⊴ h' ⟧ ⟹ P,h' ⊢ l (:≤) E"
apply (unfold lconf_def)
apply (fast elim: conf_hext)
done
lemma lconf_upd:
"⟦ P,h ⊢ l (:≤) E; P,h ⊢ v :≤ T; E V = Some T ⟧ ⟹ P,h ⊢ l(V↦v) (:≤) E"
apply (unfold lconf_def)
apply auto
done
lemma lconf_empty[iff]: "P,h ⊢ Map.empty (:≤) E"
by(simp add:lconf_def)
lemma lconf_upd2: "⟦P,h ⊢ l (:≤) E; P,h ⊢ v :≤ T⟧ ⟹ P,h ⊢ l(V↦v) (:≤) E(V↦T)"
by(simp add:lconf_def)
end
Theory Progress
section ‹Progress of Small Step Semantics›
theory Progress
imports Equivalence WellTypeRT DefAss "../Common/Conform"
begin
lemma final_addrE:
"⟦ P,E,h ⊢ e : Class C; final e;
⋀a. e = addr a ⟹ R;
⋀a. e = Throw a ⟹ R ⟧ ⟹ R"
by(auto simp:final_def)
lemma finalRefE:
"⟦ P,E,h ⊢ e : T; is_refT T; final e;
e = null ⟹ R;
⋀a C. ⟦ e = addr a; T = Class C ⟧ ⟹ R;
⋀a. e = Throw a ⟹ R ⟧ ⟹ R"
by(auto simp:final_def is_refT_def)
text‹Derivation of new induction scheme for well typing:›
inductive
WTrt' :: "[J_prog,heap,env,expr,ty] ⇒ bool"
and WTrts' :: "[J_prog,heap,env,expr list, ty list] ⇒ bool"
and WTrt2' :: "[J_prog,env,heap,expr,ty] ⇒ bool"
("_,_,_ ⊢ _ :'' _" [51,51,51]50)
and WTrts2' :: "[J_prog,env,heap,expr list, ty list] ⇒ bool"
("_,_,_ ⊢ _ [:''] _" [51,51,51]50)
for P :: J_prog and h :: heap
where
"P,E,h ⊢ e :' T ≡ WTrt' P h E e T"
| "P,E,h ⊢ es [:'] Ts ≡ WTrts' P h E es Ts"
| "is_class P C ⟹ P,E,h ⊢ new C :' Class C"
| "⟦ P,E,h ⊢ e :' T; is_refT T; is_class P C ⟧
⟹ P,E,h ⊢ Cast C e :' Class C"
| "typeof⇘h⇙ v = Some T ⟹ P,E,h ⊢ Val v :' T"
| "E v = Some T ⟹ P,E,h ⊢ Var v :' T"
| "⟦ P,E,h ⊢ e⇩1 :' T⇩1; P,E,h ⊢ e⇩2 :' T⇩2 ⟧
⟹ P,E,h ⊢ e⇩1 «Eq» e⇩2 :' Boolean"
| "⟦ P,E,h ⊢ e⇩1 :' Integer; P,E,h ⊢ e⇩2 :' Integer ⟧
⟹ P,E,h ⊢ e⇩1 «Add» e⇩2 :' Integer"
| "⟦ P,E,h ⊢ Var V :' T; P,E,h ⊢ e :' T'; P ⊢ T' ≤ T ⟧
⟹ P,E,h ⊢ V:=e :' Void"
| "⟦ P,E,h ⊢ e :' Class C; P ⊢ C has F:T in D ⟧ ⟹ P,E,h ⊢ e∙F{D} :' T"
| "P,E,h ⊢ e :' NT ⟹ P,E,h ⊢ e∙F{D} :' T"
| "⟦ P,E,h ⊢ e⇩1 :' Class C; P ⊢ C has F:T in D;
P,E,h ⊢ e⇩2 :' T⇩2; P ⊢ T⇩2 ≤ T ⟧
⟹ P,E,h ⊢ e⇩1∙F{D}:=e⇩2 :' Void"
| "⟦ P,E,h ⊢ e⇩1:'NT; P,E,h ⊢ e⇩2 :' T⇩2 ⟧ ⟹ P,E,h ⊢ e⇩1∙F{D}:=e⇩2 :' Void"
| "⟦ P,E,h ⊢ e :' Class C; P ⊢ C sees M:Ts → T = (pns,body) in D;
P,E,h ⊢ es [:'] Ts'; P ⊢ Ts' [≤] Ts ⟧
⟹ P,E,h ⊢ e∙M(es) :' T"
| "⟦ P,E,h ⊢ e :' NT; P,E,h ⊢ es [:'] Ts ⟧ ⟹ P,E,h ⊢ e∙M(es) :' T"
| "P,E,h ⊢ [] [:'] []"
| "⟦ P,E,h ⊢ e :' T; P,E,h ⊢ es [:'] Ts ⟧ ⟹ P,E,h ⊢ e#es [:'] T#Ts"
| "⟦ typeof⇘h⇙ v = Some T⇩1; P ⊢ T⇩1 ≤ T; P,E(V↦T),h ⊢ e⇩2 :' T⇩2 ⟧
⟹ P,E,h ⊢ {V:T := Val v; e⇩2} :' T⇩2"
| "⟦ P,E(V↦T),h ⊢ e :' T'; ¬ assigned V e ⟧ ⟹ P,E,h ⊢ {V:T; e} :' T'"
| "⟦ P,E,h ⊢ e⇩1:' T⇩1; P,E,h ⊢ e⇩2:'T⇩2 ⟧ ⟹ P,E,h ⊢ e⇩1;;e⇩2 :' T⇩2"
| "⟦ P,E,h ⊢ e :' Boolean; P,E,h ⊢ e⇩1:' T⇩1; P,E,h ⊢ e⇩2:' T⇩2;
P ⊢ T⇩1 ≤ T⇩2 ∨ P ⊢ T⇩2 ≤ T⇩1;
P ⊢ T⇩1 ≤ T⇩2 ⟶ T = T⇩2; P ⊢ T⇩2 ≤ T⇩1 ⟶ T = T⇩1 ⟧
⟹ P,E,h ⊢ if (e) e⇩1 else e⇩2 :' T"
| "⟦ P,E,h ⊢ e :' Boolean; P,E,h ⊢ c:' T ⟧
⟹ P,E,h ⊢ while(e) c :' Void"
| "⟦ P,E,h ⊢ e :' T⇩r; is_refT T⇩r ⟧ ⟹ P,E,h ⊢ throw e :' T"
| "⟦ P,E,h ⊢ e⇩1 :' T⇩1; P,E(V ↦ Class C),h ⊢ e⇩2 :' T⇩2; P ⊢ T⇩1 ≤ T⇩2 ⟧
⟹ P,E,h ⊢ try e⇩1 catch(C V) e⇩2 :' T⇩2"
lemmas WTrt'_induct = WTrt'_WTrts'.induct [split_format (complete)]
and WTrt'_inducts = WTrt'_WTrts'.inducts [split_format (complete)]
inductive_cases WTrt'_elim_cases[elim!]:
"P,E,h ⊢ V :=e :' T"
lemma [iff]: "P,E,h ⊢ e⇩1;;e⇩2 :' T⇩2 = (∃T⇩1. P,E,h ⊢ e⇩1:' T⇩1 ∧ P,E,h ⊢ e⇩2:' T⇩2)"
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
lemma [iff]: "P,E,h ⊢ Val v :' T = (typeof⇘h⇙ v = Some T)"
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
lemma [iff]: "P,E,h ⊢ Var v :' T = (E v = Some T)"
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
lemma wt_wt': "P,E,h ⊢ e : T ⟹ P,E,h ⊢ e :' T"
and wts_wts': "P,E,h ⊢ es [:] Ts ⟹ P,E,h ⊢ es [:'] Ts"
apply (induct rule:WTrt_inducts)
prefer 14
apply(case_tac "assigned V e")
apply(clarsimp simp add:fun_upd_same assigned_def simp del:fun_upd_apply)
apply(erule (2) WTrt'_WTrts'.intros)
apply(erule (1) WTrt'_WTrts'.intros)
apply(blast intro:WTrt'_WTrts'.intros)+
done
lemma wt'_wt: "P,E,h ⊢ e :' T ⟹ P,E,h ⊢ e : T"
and wts'_wts: "P,E,h ⊢ es [:'] Ts ⟹ P,E,h ⊢ es [:] Ts"
apply (induct rule:WTrt'_inducts)
prefer 16
apply(rule WTrt_WTrts.intros)
apply(rule WTrt_WTrts.intros)
apply(rule WTrt_WTrts.intros)
apply simp
apply(erule (2) WTrt_WTrts.intros)
apply(blast intro:WTrt_WTrts.intros)+
done
corollary wt'_iff_wt: "(P,E,h ⊢ e :' T) = (P,E,h ⊢ e : T)"
by(blast intro:wt_wt' wt'_wt)
corollary wts'_iff_wts: "(P,E,h ⊢ es [:'] Ts) = (P,E,h ⊢ es [:] Ts)"
by(blast intro:wts_wts' wts'_wts)
lemmas WTrt_inducts2 = WTrt'_inducts [unfolded wt'_iff_wt wts'_iff_wts,
case_names WTrtNew WTrtCast WTrtVal WTrtVar WTrtBinOpEq WTrtBinOpAdd WTrtLAss WTrtFAcc WTrtFAccNT WTrtFAss
WTrtFAssNT WTrtCall WTrtCallNT WTrtNil WTrtCons WTrtInitBlock WTrtBlock WTrtSeq WTrtCond
WTrtWhile WTrtThrow WTrtTry, consumes 1]
theorem assumes wf: "wwf_J_prog P" and hconf: "P ⊢ h √"
shows progress: "P,E,h ⊢ e : T ⟹
(⋀l. ⟦ 𝒟 e ⌊dom l⌋; ¬ final e ⟧ ⟹ ∃e' s'. P ⊢ ⟨e,(h,l)⟩ → ⟨e',s'⟩)"
and "P,E,h ⊢ es [:] Ts ⟹
(⋀l. ⟦ 𝒟s es ⌊dom l⌋; ¬ finals es ⟧ ⟹ ∃es' s'. P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',s'⟩)"
proof (induct rule:WTrt_inducts2)
case WTrtNew
show ?case
proof cases
assume "∃a. h a = None"
with assms WTrtNew show ?thesis
by (fastforce del:exE intro!:RedNew simp add:new_Addr_def
elim!:wf_Fields_Ex[THEN exE])
next
assume "¬(∃a. h a = None)"
with assms WTrtNew show ?thesis
by(fastforce intro:RedNewFail simp add:new_Addr_def)
qed
next
case (WTrtCast E e T C)
have wte: "P,E,h ⊢ e : T" and ref: "is_refT T"
and IH: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧
⟹ ∃e' s'. P ⊢ ⟨e,(h,l)⟩ → ⟨e',s'⟩"
and D: "𝒟 (Cast C e) ⌊dom l⌋" by fact+
from D have De: "𝒟 e ⌊dom l⌋" by auto
show ?case
proof cases
assume "final e"
with wte ref show ?thesis
proof (rule finalRefE)
assume "e = null" thus ?case by(fastforce intro:RedCastNull)
next
fix D a assume A: "T = Class D" "e = addr a"
show ?thesis
proof cases
assume "P ⊢ D ≼⇧* C"
thus ?thesis using A wte by(fastforce intro:RedCast)
next
assume "¬ P ⊢ D ≼⇧* C"
thus ?thesis using A wte by(force intro!:RedCastFail)
qed
next
fix a assume "e = Throw a"
thus ?thesis by(blast intro!:red_reds.CastThrow)
qed
next
assume nf: "¬ final e"
from IH[OF De nf] show ?thesis by (blast intro:CastRed)
qed
next
case WTrtVal thus ?case by(simp add:final_def)
next
case WTrtVar thus ?case by(fastforce intro:RedVar simp:hyper_isin_def)
next
case (WTrtBinOpEq E e1 T1 e2 T2)
show ?case
proof cases
assume "final e1"
thus ?thesis
proof (rule finalE)
fix v1 assume [simp]: "e1 = Val v1"
show ?thesis
proof cases
assume "final e2"
thus ?thesis
proof (rule finalE)
fix v2 assume "e2 = Val v2"
thus ?thesis using WTrtBinOpEq by(fastforce intro:RedBinOp)
next
fix a assume "e2 = Throw a"
thus ?thesis by(auto intro:red_reds.BinOpThrow2)
qed
next
assume "¬ final e2" with WTrtBinOpEq show ?thesis
by simp (fast intro!:BinOpRed2)
qed
next
fix a assume "e1 = Throw a"
thus ?thesis by simp (fast intro:red_reds.BinOpThrow1)
qed
next
assume "¬ final e1" with WTrtBinOpEq show ?thesis
by simp (fast intro:BinOpRed1)
qed
next
case (WTrtBinOpAdd E e1 e2)
show ?case
proof cases
assume "final e1"
thus ?thesis
proof (rule finalE)
fix v1 assume [simp]: "e1 = Val v1"
show ?thesis
proof cases
assume "final e2"
thus ?thesis
proof (rule finalE)
fix v2 assume "e2 = Val v2"
thus ?thesis using WTrtBinOpAdd by(fastforce intro:RedBinOp)
next
fix a assume "e2 = Throw a"
thus ?thesis by(auto intro:red_reds.BinOpThrow2)
qed
next
assume "¬ final e2" with WTrtBinOpAdd show ?thesis
by simp (fast intro!:BinOpRed2)
qed
next
fix a assume "e1 = Throw a"
thus ?thesis by simp (fast intro:red_reds.BinOpThrow1)
qed
next
assume "¬ final e1" with WTrtBinOpAdd show ?thesis
by simp (fast intro:BinOpRed1)
qed
next
case (WTrtLAss E V T e T')
show ?case
proof cases
assume "final e" with WTrtLAss show ?thesis
by(auto simp:final_def intro!:RedLAss red_reds.LAssThrow)
next
assume "¬ final e" with WTrtLAss show ?thesis
by simp (fast intro:LAssRed)
qed
next
case (WTrtFAcc E e C F T D)
have wte: "P,E,h ⊢ e : Class C"
and field: "P ⊢ C has F:T in D" by fact+
show ?case
proof cases
assume "final e"
with wte show ?thesis
proof (rule final_addrE)
fix a assume e: "e = addr a"
with wte obtain fs where hp: "h a = Some(C,fs)" by auto
with hconf have "P,h ⊢ (C,fs) √" using hconf_def by fastforce
then obtain v where "fs(F,D) = Some v" using field
by(fastforce dest:has_fields_fun simp:oconf_def has_field_def)
with hp e show ?thesis by(fastforce intro:RedFAcc)
next
fix a assume "e = Throw a"
thus ?thesis by(fastforce intro:red_reds.FAccThrow)
qed
next
assume "¬ final e" with WTrtFAcc show ?thesis
by(fastforce intro!:FAccRed)
qed
next
case (WTrtFAccNT E e F D T)
show ?case
proof cases
assume "final e"
with WTrtFAccNT show ?thesis
by(fastforce simp:final_def intro: RedFAccNull red_reds.FAccThrow)
next
assume "¬ final e"
with WTrtFAccNT show ?thesis by simp (fast intro:FAccRed)
qed
next
case (WTrtFAss E e1 C F T D e2 T2)
have wte1: "P,E,h ⊢ e1 : Class C" by fact
show ?case
proof cases
assume "final e1"
with wte1 show ?thesis
proof (rule final_addrE)
fix a assume e1: "e1 = addr a"
show ?thesis
proof cases
assume "final e2"
thus ?thesis
proof (rule finalE)
fix v assume "e2 = Val v"
thus ?thesis using e1 wte1 by(fastforce intro:RedFAss)
next
fix a assume "e2 = Throw a"
thus ?thesis using e1 by(fastforce intro:red_reds.FAssThrow2)
qed
next
assume "¬ final e2" with WTrtFAss e1 show ?thesis
by simp (fast intro!:FAssRed2)
qed
next
fix a assume "e1 = Throw a"
thus ?thesis by(fastforce intro:red_reds.FAssThrow1)
qed
next
assume "¬ final e1" with WTrtFAss show ?thesis
by simp (blast intro!:FAssRed1)
qed
next
case (WTrtFAssNT E e⇩1 e⇩2 T⇩2 F D)
show ?case
proof cases
assume e1: "final e⇩1"
show ?thesis
proof cases
assume "final e⇩2"
with WTrtFAssNT e1 show ?thesis
by(fastforce simp:final_def intro: RedFAssNull red_reds.FAssThrow1 red_reds.FAssThrow2)
next
assume "¬ final e⇩2"
with WTrtFAssNT e1 show ?thesis
by (fastforce simp:final_def intro!:red_reds.FAssRed2 red_reds.FAssThrow1)
qed
next
assume "¬ final e⇩1"
with WTrtFAssNT show ?thesis by (fastforce intro:FAssRed1)
qed
next
case (WTrtCall E e C M Ts T pns body D es Ts')
have wte: "P,E,h ⊢ e : Class C"
and "method": "P ⊢ C sees M:Ts→T = (pns,body) in D"
and wtes: "P,E,h ⊢ es [:] Ts'"and sub: "P ⊢ Ts' [≤] Ts"
and IHes: "⋀l.
⟦𝒟s es ⌊dom l⌋; ¬ finals es⟧
⟹ ∃es' s'. P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',s'⟩"
and D: "𝒟 (e∙M(es)) ⌊dom l⌋" by fact+
show ?case
proof cases
assume "final e"
with wte show ?thesis
proof (rule final_addrE)
fix a assume e_addr: "e = addr a"
show ?thesis
proof cases
assume es: "∃vs. es = map Val vs"
from wte e_addr obtain fs where ha: "h a = Some(C,fs)" by auto
show ?thesis
using e_addr ha "method" WTrts_same_length[OF wtes] sub es sees_wf_mdecl[OF wf "method"]
by (fastforce intro!: RedCall simp:list_all2_iff wf_mdecl_def)
next
assume "¬(∃vs. es = map Val vs)"
hence not_all_Val: "¬(∀e ∈ set es. ∃v. e = Val v)"
by(simp add:ex_map_conv)
let ?ves = "takeWhile (λe. ∃v. e = Val v) es"
let ?rest = "dropWhile (λe. ∃v. e = Val v) es"
let ?ex = "hd ?rest" let ?rst = "tl ?rest"
from not_all_Val have nonempty: "?rest ≠ []" by auto
hence es: "es = ?ves @ ?ex # ?rst" by simp
have "∀e ∈ set ?ves. ∃v. e = Val v" by(fastforce dest:set_takeWhileD)
then obtain vs where ves: "?ves = map Val vs"
using ex_map_conv by blast
show ?thesis
proof cases
assume "final ?ex"
moreover from nonempty have "¬(∃v. ?ex = Val v)"
by(auto simp:neq_Nil_conv simp del:dropWhile_eq_Nil_conv)
(simp add:dropWhile_eq_Cons_conv)
ultimately obtain b where ex_Throw: "?ex = Throw b"
by(fast elim!:finalE)
show ?thesis using e_addr es ex_Throw ves
by(fastforce intro:CallThrowParams)
next
assume not_fin: "¬ final ?ex"
have "finals es = finals(?ves @ ?ex # ?rst)" using es
by(rule arg_cong)
also have "… = finals(?ex # ?rst)" using ves by simp
finally have "finals es = finals(?ex # ?rst)" .
hence "¬ finals es" using not_finals_ConsI[OF not_fin] by blast
thus ?thesis using e_addr D IHes by(fastforce intro!:CallParams)
qed
qed
next
fix a assume "e = Throw a"
with WTrtCall.prems show ?thesis by(fast intro!:CallThrowObj)
qed
next
assume "¬ final e"
with WTrtCall show ?thesis by simp (blast intro!:CallObj)
qed
next
case (WTrtCallNT E e es Ts M T)
show ?case
proof cases
assume "final e"
moreover
{ fix v assume e: "e = Val v"
hence "e = null" using WTrtCallNT by simp
have ?case
proof cases
assume "finals es"
moreover
{ fix vs assume "es = map Val vs"
with WTrtCallNT e have ?thesis by(fastforce intro: RedCallNull) }
moreover
{ fix vs a es' assume "es = map Val vs @ Throw a # es'"
with WTrtCallNT e have ?thesis by(fastforce intro: CallThrowParams) }
ultimately show ?thesis by(fastforce simp:finals_def)
next
assume "¬ finals es"
with WTrtCallNT e show ?thesis by(fastforce intro: CallParams)
qed
}
moreover
{ fix a assume "e = Throw a"
with WTrtCallNT have ?case by(fastforce intro: CallThrowObj) }
ultimately show ?thesis by(fastforce simp:final_def)
next
assume "¬ final e"
with WTrtCallNT show ?thesis by (fastforce intro:CallObj)
qed
next
case WTrtNil thus ?case by simp
next
case (WTrtCons E e T es Ts)
have IHe: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧
⟹ ∃e' s'. P ⊢ ⟨e,(h,l)⟩ → ⟨e',s'⟩"
and IHes: "⋀l. ⟦𝒟s es ⌊dom l⌋; ¬ finals es⟧
⟹ ∃es' s'. P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',s'⟩"
and D: "𝒟s (e#es) ⌊dom l⌋" and not_fins: "¬ finals(e # es)" by fact+
have De: "𝒟 e ⌊dom l⌋" and Des: "𝒟s es (⌊dom l⌋ ⊔ 𝒜 e)"
using D by auto
show ?case
proof cases
assume "final e"
thus ?thesis
proof (rule finalE)
fix v assume e: "e = Val v"
hence Des': "𝒟s es ⌊dom l⌋" using De Des by auto
have not_fins_tl: "¬ finals es" using not_fins e by simp
show ?thesis using e IHes[OF Des' not_fins_tl]
by (blast intro!:ListRed2)
next
fix a assume "e = Throw a"
hence False using not_fins by simp
thus ?thesis ..
qed
next
assume "¬ final e"
with IHe[OF De] show ?thesis by(fast intro!:ListRed1)
qed
next
case (WTrtInitBlock v T⇩1 T E V e⇩2 T⇩2)
have IH2: "⋀l. ⟦𝒟 e⇩2 ⌊dom l⌋; ¬ final e⇩2⟧
⟹ ∃e' s'. P ⊢ ⟨e⇩2,(h,l)⟩ → ⟨e',s'⟩"
and D: "𝒟 {V:T := Val v; e⇩2} ⌊dom l⌋" by fact+
show ?case
proof cases
assume "final e⇩2"
then show ?thesis
proof (rule finalE)
fix v⇩2 assume "e⇩2 = Val v⇩2"
thus ?thesis by(fast intro:RedInitBlock)
next
fix a assume "e⇩2 = Throw a"
thus ?thesis by(fast intro:red_reds.InitBlockThrow)
qed
next
assume not_fin2: "¬ final e⇩2"
from D have D2: "𝒟 e⇩2 ⌊dom(l(V↦v))⌋" by (auto simp:hyperset_defs)
from IH2[OF D2 not_fin2]
obtain h' l' e' where red2: "P ⊢ ⟨e⇩2,(h, l(V↦v))⟩ → ⟨e',(h', l')⟩"
by auto
from red_lcl_incr[OF red2] have "V ∈ dom l'" by auto
with red2 show ?thesis by(fastforce intro:InitBlockRed)
qed
next
case (WTrtBlock E V T e T')
have IH: "⋀l. ⟦𝒟 e ⌊dom l⌋; ¬ final e⟧
⟹ ∃e' s'. P ⊢ ⟨e,(h,l)⟩ → ⟨e',s'⟩"
and unass: "¬ assigned V e" and D: "𝒟 {V:T; e} ⌊dom l⌋" by fact+
show ?case
proof cases
assume "final e"
thus ?thesis
proof (rule finalE)
fix v assume "e = Val v" thus ?thesis by(fast intro:RedBlock)
next
fix a assume "e = Throw a"
thus ?thesis by(fast intro:red_reds.BlockThrow)
qed
next
assume not_fin: "¬ final e"
from D have De: "𝒟 e ⌊dom(l(V:=None))⌋" by(simp add:hyperset_defs)
from IH[OF De not_fin]
obtain h' l' e' where red: "P ⊢ ⟨e,(h,l(V:=None))⟩ → ⟨e',(h',l')⟩"
by auto
show ?thesis
proof (cases "l' V")
assume "l' V = None"
with red unass show ?thesis by(blast intro: BlockRedNone)
next
fix v assume "l' V = Some v"
with red unass show ?thesis by(blast intro: BlockRedSome)
qed
qed
next
case (WTrtSeq E e1 T1 e2 T2)
show ?case
proof cases
assume "final e1"
thus ?thesis
by(fast elim:finalE intro:RedSeq red_reds.SeqThrow)
next
assume "¬ final e1" with WTrtSeq show ?thesis
by simp (blast intro:SeqRed)
qed
next
case (WTrtCond E e e⇩1 T⇩1 e⇩2 T⇩2 T)
have wt: "P,E,h ⊢ e : Boolean" by fact
show ?case
proof cases
assume "final e"
thus ?thesis
proof (rule finalE)
fix v assume val: "e = Val v"
then obtain b where v: "v = Bool b" using wt by auto
show ?thesis
proof (cases b)
case True with val v show ?thesis by(auto intro:RedCondT)
next
case False with val v show ?thesis by(auto intro:RedCondF)
qed
next
fix a assume "e = Throw a"
thus ?thesis by(fast intro:red_reds.CondThrow)
qed
next
assume "¬ final e" with WTrtCond show ?thesis
by simp (fast intro:CondRed)
qed
next
case WTrtWhile show ?case by(fast intro:RedWhile)
next
case (WTrtThrow E e T⇩r T)
show ?case
proof cases
assume "final e"
with WTrtThrow show ?thesis
by(fastforce simp:final_def is_refT_def
intro:red_reds.ThrowThrow red_reds.RedThrowNull)
next
assume "¬ final e"
with WTrtThrow show ?thesis by simp (blast intro:ThrowRed)
qed
next
case (WTrtTry E e1 T1 V C e2 T2)
have wt1: "P,E,h ⊢ e1 : T1" by fact
show ?case
proof cases
assume "final e1"
thus ?thesis
proof (rule finalE)
fix v assume "e1 = Val v"
thus ?thesis by(fast intro:RedTry)
next
fix a assume e1_Throw: "e1 = Throw a"
with wt1 obtain D fs where ha: "h a = Some(D,fs)" by fastforce
show ?thesis
proof cases
assume "P ⊢ D ≼⇧* C"
with e1_Throw ha show ?thesis by(fastforce intro!:RedTryCatch)
next
assume "¬ P ⊢ D ≼⇧* C"
with e1_Throw ha show ?thesis by(force intro!:RedTryFail)
qed
qed
next
assume "¬ final e1"
with WTrtTry show ?thesis by simp (fast intro:TryRed)
qed
qed
end
Theory TypeSafe
section ‹Type Safety Proof›
theory TypeSafe
imports Progress JWellForm
begin
subsection‹Basic preservation lemmas›
text‹First two easy preservation lemmas.›
theorem red_preserves_hconf:
"P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩ ⟹ (⋀T E. ⟦ P,E,h ⊢ e : T; P ⊢ h √ ⟧ ⟹ P ⊢ h' √)"
and reds_preserves_hconf:
"P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩ ⟹ (⋀Ts E. ⟦ P,E,h ⊢ es [:] Ts; P ⊢ h √ ⟧ ⟹ P ⊢ h' √)"
proof (induct rule:red_reds_inducts)
case (RedNew h a C FDTs h' l)
have new: "new_Addr h = Some a" and fields: "P ⊢ C has_fields FDTs"
and h': "h' = h(a↦(C, init_fields FDTs))"
and hconf: "P ⊢ h √" by fact+
from new have None: "h a = None" by(rule new_Addr_SomeD)
moreover have "P,h ⊢ (C,init_fields FDTs) √"
using fields by(rule oconf_init_fields)
ultimately show "P ⊢ h' √" using h' by(fast intro: hconf_new[OF hconf])
next
case (RedFAss h a C fs F D v l)
let ?fs' = "fs((F,D)↦v)"
have hconf: "P ⊢ h √" and ha: "h a = Some(C,fs)"
and wt: "P,E,h ⊢ addr a∙F{D}:=Val v : T" by fact+
from wt ha obtain TF Tv where typeofv: "typeof⇘h⇙ v = Some Tv"
and has: "P ⊢ C has F:TF in D"
and sub: "P ⊢ Tv ≤ TF" by auto
have "P,h ⊢ (C, ?fs') √"
proof (rule oconf_fupd[OF has])
show "P,h ⊢ (C, fs) √" using hconf ha by(simp add:hconf_def)
show "P,h ⊢ v :≤ TF" using sub typeofv by(simp add:conf_def)
qed
with hconf ha show "P ⊢ h(a↦(C, ?fs')) √" by (rule hconf_upd_obj)
qed auto
theorem red_preserves_lconf:
"P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩ ⟹
(⋀T E. ⟦ P,E,h ⊢ e:T; P,h ⊢ l (:≤) E ⟧ ⟹ P,h' ⊢ l' (:≤) E)"
and reds_preserves_lconf:
"P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩ ⟹
(⋀Ts E. ⟦ P,E,h ⊢ es[:]Ts; P,h ⊢ l (:≤) E ⟧ ⟹ P,h' ⊢ l' (:≤) E)"
proof(induct rule:red_reds_inducts)
case RedNew thus ?case
by(fast intro:lconf_hext red_hext_incr[OF red_reds.RedNew])
next
case RedLAss thus ?case by(fastforce elim: lconf_upd simp:conf_def)
next
case RedFAss thus ?case
by(fast intro:lconf_hext red_hext_incr[OF red_reds.RedFAss])
next
case (InitBlockRed e h l V v e' h' l' v' T T')
have red: "P ⊢ ⟨e, (h, l(V↦v))⟩ → ⟨e',(h', l')⟩"
and IH: "⋀T E . ⟦ P,E,h ⊢ e:T; P,h ⊢ l(V↦v) (:≤) E ⟧
⟹ P,h' ⊢ l' (:≤) E"
and l'V: "l' V = Some v'" and lconf: "P,h ⊢ l (:≤) E"
and wt: "P,E,h ⊢ {V:T := Val v; e} : T'" by fact+
from lconf_hext[OF lconf red_hext_incr[OF red]]
have "P,h' ⊢ l (:≤) E" .
moreover from IH lconf wt have "P,h' ⊢ l' (:≤) E(V↦T)"
by(auto simp del: fun_upd_apply simp: fun_upd_same lconf_upd2 conf_def)
ultimately show "P,h' ⊢ l'(V := l V) (:≤) E"
by (fastforce simp:lconf_def split:if_split_asm)
next
case (BlockRedNone e h l V e' h' l' T T')
have red: "P ⊢ ⟨e,(h, l(V := None))⟩ → ⟨e',(h', l')⟩"
and IH: "⋀E T. ⟦ P,E,h ⊢ e : T; P,h ⊢ l(V:=None) (:≤) E ⟧
⟹ P,h' ⊢ l' (:≤) E"
and lconf: "P,h ⊢ l (:≤) E" and wt: "P,E,h ⊢ {V:T; e} : T'" by fact+
from lconf_hext[OF lconf red_hext_incr[OF red]]
have "P,h' ⊢ l (:≤) E" .
moreover have "P,h' ⊢ l' (:≤) E(V↦T)"
by(rule IH, insert lconf wt, auto simp:lconf_def)
ultimately show "P,h' ⊢ l'(V := l V) (:≤) E"
by (fastforce simp:lconf_def split:if_split_asm)
next
case (BlockRedSome e h l V e' h' l' v T T')
have red: "P ⊢ ⟨e,(h, l(V := None))⟩ → ⟨e',(h', l')⟩"
and IH: "⋀E T. ⟦P,E,h ⊢ e : T; P,h ⊢ l(V:=None) (:≤) E⟧
⟹ P,h' ⊢ l' (:≤) E"
and lconf: "P,h ⊢ l (:≤) E" and wt: "P,E,h ⊢ {V:T; e} : T'" by fact+
from lconf_hext[OF lconf red_hext_incr[OF red]]
have "P,h' ⊢ l (:≤) E" .
moreover have "P,h' ⊢ l' (:≤) E(V↦T)"
by(rule IH, insert lconf wt, auto simp:lconf_def)
ultimately show "P,h' ⊢ l'(V := l V) (:≤) E"
by (fastforce simp:lconf_def split:if_split_asm)
qed auto
text‹Preservation of definite assignment more complex and requires a
few lemmas first.›
lemma [iff]: "⋀A. ⟦ length Vs = length Ts; length vs = length Ts⟧ ⟹
𝒟 (blocks (Vs,Ts,vs,e)) A = 𝒟 e (A ⊔ ⌊set Vs⌋)"
apply(induct Vs Ts vs e rule:blocks_induct)
apply(simp_all add:hyperset_defs)
done
lemma red_lA_incr: "P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩ ⟹ ⌊dom l⌋ ⊔ 𝒜 e ⊑ ⌊dom l'⌋ ⊔ 𝒜 e'"
and reds_lA_incr: "P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩ ⟹ ⌊dom l⌋ ⊔ 𝒜s es ⊑ ⌊dom l'⌋ ⊔ 𝒜s es'"
apply(induct rule:red_reds_inducts)
apply(simp_all del:fun_upd_apply add:hyperset_defs)
apply auto
apply(blast dest:red_lcl_incr)+
done
text‹Now preservation of definite assignment.›
lemma assumes wf: "wf_J_prog P"
shows red_preserves_defass:
"P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩ ⟹ 𝒟 e ⌊dom l⌋ ⟹ 𝒟 e' ⌊dom l'⌋"
and "P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩ ⟹ 𝒟s es ⌊dom l⌋ ⟹ 𝒟s es' ⌊dom l'⌋"
proof (induct rule:red_reds_inducts)
case BinOpRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case FAssRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case CallObj thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
next
case RedCall thus ?case
apply (auto dest!:sees_wf_mdecl[OF wf] simp:wf_mdecl_def elim!:D_mono')
by(auto simp:hyperset_defs)
next
case InitBlockRed thus ?case
by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply)
next
case BlockRedNone thus ?case
by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply)
next
case BlockRedSome thus ?case
by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply)
next
case SeqRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case CondRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
case TryRed thus ?case
by (fastforce dest:red_lcl_incr intro:D_mono' simp:hyperset_defs)
next
case ListRed1 thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
next
case RedWhile thus ?case by(auto simp:hyperset_defs elim!:D_mono')
qed (auto simp:hyperset_defs)
text‹Combining conformance of heap and local variables:›
definition sconf :: "J_prog ⇒ env ⇒ state ⇒ bool" ("_,_ ⊢ _ √" [51,51,51]50)
where
"P,E ⊢ s √ ≡ let (h,l) = s in P ⊢ h √ ∧ P,h ⊢ l (:≤) E"
lemma red_preserves_sconf:
"⟦ P ⊢ ⟨e,s⟩ → ⟨e',s'⟩; P,E,hp s ⊢ e : T; P,E ⊢ s √ ⟧ ⟹ P,E ⊢ s' √"
by(fastforce intro:red_preserves_hconf red_preserves_lconf
simp add:sconf_def)
lemma reds_preserves_sconf:
"⟦ P ⊢ ⟨es,s⟩ [→] ⟨es',s'⟩; P,E,hp s ⊢ es [:] Ts; P,E ⊢ s √ ⟧ ⟹ P,E ⊢ s' √"
by(fastforce intro:reds_preserves_hconf reds_preserves_lconf
simp add:sconf_def)
subsection "Subject reduction"
lemma wt_blocks:
"⋀E. ⟦ length Vs = length Ts; length vs = length Ts ⟧ ⟹
(P,E,h ⊢ blocks(Vs,Ts,vs,e) : T) =
(P,E(Vs[↦]Ts),h ⊢ e:T ∧ (∃Ts'. map (typeof⇘h⇙) vs = map Some Ts' ∧ P ⊢ Ts' [≤] Ts))"
apply(induct Vs Ts vs e rule:blocks_induct)
apply (force simp add:rel_list_all2_Cons2)
apply simp_all
done
theorem assumes wf: "wf_J_prog P"
shows subject_reduction2: "P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩ ⟹
(⋀E T. ⟦ P,E ⊢ (h,l) √; P,E,h ⊢ e:T ⟧
⟹ ∃T'. P,E,h' ⊢ e':T' ∧ P ⊢ T' ≤ T)"
and subjects_reduction2: "P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩ ⟹
(⋀E Ts. ⟦ P,E ⊢ (h,l) √; P,E,h ⊢ es [:] Ts ⟧
⟹ ∃Ts'. P,E,h' ⊢ es' [:] Ts' ∧ P ⊢ Ts' [≤] Ts)"
proof (induct rule:red_reds_inducts)
case (RedCall h l a C fs M Ts T pns body D vs E T')
have hp: "hp(h,l) a = Some(C,fs)"
and "method": "P ⊢ C sees M: Ts→T = (pns,body) in D"
and wt: "P,E,h ⊢ addr a∙M(map Val vs) : T'" by fact+
obtain Ts' where wtes: "P,E,h ⊢ map Val vs [:] Ts'"
and subs: "P ⊢ Ts' [≤] Ts" and T'isT: "T' = T"
using wt "method" hp by (auto dest:sees_method_fun)
from wtes subs have length_vs: "length vs = length Ts"
by(fastforce simp:list_all2_iff dest!:WTrts_same_length)
from sees_wf_mdecl[OF wf "method"] obtain T''
where wtabody: "P,[this#pns [↦] Class D#Ts] ⊢ body :: T''"
and T''subT: "P ⊢ T'' ≤ T" and length_pns: "length pns = length Ts"
by(fastforce simp:wf_mdecl_def simp del:map_upds_twist)
from wtabody have "P,Map.empty(this#pns [↦] Class D#Ts),h ⊢ body : T''"
by(rule WT_implies_WTrt)
hence "P,E(this#pns [↦] Class D#Ts),h ⊢ body : T''"
by(rule WTrt_env_mono) simp
hence "P,E,h ⊢ blocks(this#pns, Class D#Ts, Addr a#vs, body) : T''"
using wtes subs hp sees_method_decl_above[OF "method"] length_vs length_pns
by(fastforce simp add:wt_blocks rel_list_all2_Cons2)
with T''subT T'isT show ?case by blast
next
case RedNewFail thus ?case
by (unfold sconf_def hconf_def) (fastforce elim!:typeof_OutOfMemory)
next
case CastRed thus ?case
by(clarsimp simp:is_refT_def)
(blast intro: widens_trans dest!:widen_Class[THEN iffD1])
next
case RedCastFail thus ?case
by (unfold sconf_def hconf_def) (fastforce elim!:typeof_ClassCast)
next
case (BinOpRed1 e⇩1 h l e⇩1' h' l' bop e⇩2)
have red: "P ⊢ ⟨e⇩1,(h,l)⟩ → ⟨e⇩1',(h',l')⟩"
and IH: "⋀E T. ⟦P,E ⊢ (h,l) √; P,E,h ⊢ e⇩1:T⟧
⟹ ∃U. P,E,h' ⊢ e⇩1' : U ∧ P ⊢ U ≤ T"
and conf: "P,E ⊢ (h,l) √" and wt: "P,E,h ⊢ e⇩1 «bop» e⇩2 : T" by fact+
have "P,E,h' ⊢ e⇩1' «bop» e⇩2 : T"
proof (cases bop)
assume [simp]: "bop = Eq"
from wt obtain T⇩1 T⇩2 where [simp]: "T = Boolean"
and wt⇩1: "P,E,h ⊢ e⇩1 : T⇩1" and wt⇩2: "P,E,h ⊢ e⇩2 : T⇩2" by auto
show ?thesis
using WTrt_hext_mono[OF wt⇩2 red_hext_incr[OF red]] IH[OF conf wt⇩1]
by auto
next
assume [simp]: "bop = Add"
from wt have [simp]: "T = Integer"
and wt⇩1: "P,E,h ⊢ e⇩1 : Integer" and wt⇩2: "P,E,h ⊢ e⇩2 : Integer"
by auto
show ?thesis
using IH[OF conf wt⇩1] WTrt_hext_mono[OF wt⇩2 red_hext_incr[OF red]]
by auto
qed
thus ?case by auto
next
case (BinOpRed2 e⇩2 h l e⇩2' h' l' v⇩1 bop)
have red: "P ⊢ ⟨e⇩2,(h,l)⟩ → ⟨e⇩2',(h',l')⟩"
and IH: "⋀E T. ⟦P,E ⊢ (h,l) √; P,E,h ⊢ e⇩2:T⟧
⟹ ∃U. P,E,h' ⊢ e⇩2' : U ∧ P ⊢ U ≤ T"
and conf: "P,E ⊢ (h,l) √" and wt: "P,E,h ⊢ (Val v⇩1) «bop» e⇩2 : T" by fact+
have "P,E,h' ⊢ (Val v⇩1) «bop» e⇩2' : T"
proof (cases bop)
assume [simp]: "bop = Eq"
from wt obtain T⇩1 T⇩2 where [simp]: "T = Boolean"
and wt⇩1: "P,E,h ⊢ Val v⇩1 : T⇩1" and wt⇩2: "P,E,h ⊢ e⇩2:T⇩2" by auto
show ?thesis
using IH[OF conf wt⇩2] WTrt_hext_mono[OF wt⇩1 red_hext_incr[OF red]]
by auto
next
assume [simp]: "bop = Add"
from wt have [simp]: "T = Integer"
and wt⇩1: "P,E,h ⊢ Val v⇩1 : Integer" and wt⇩2: "P,E,h ⊢ e⇩2 : Integer"
by auto
show ?thesis
using IH[OF conf wt⇩2] WTrt_hext_mono[OF wt⇩1 red_hext_incr[OF red]]
by auto
qed
thus ?case by auto
next
case (RedBinOp bop) thus ?case
proof (cases bop)
case Eq thus ?thesis using RedBinOp by auto
next
case Add thus ?thesis using RedBinOp by auto
qed
next
case RedVar thus ?case by (fastforce simp:sconf_def lconf_def conf_def)
next
case LAssRed thus ?case by(blast intro:widen_trans)
next
case (FAccRed e h l e' h' l' F D)
have IH: "⋀E T. ⟦P,E ⊢ (h,l) √; P,E,h ⊢ e : T⟧
⟹ ∃U. P,E,h' ⊢ e' : U ∧ P ⊢ U ≤ T"
and conf: "P,E ⊢ (h,l) √" and wt: "P,E,h ⊢ e∙F{D} : T" by fact+
{ fix C assume wte: "P,E,h ⊢ e : Class C"
and has: "P ⊢ C has F:T in D"
from IH[OF conf wte]
obtain U where wte': "P,E,h' ⊢ e' : U" and UsubC: "P ⊢ U ≤ Class C"
by auto
{ assume "U = NT" hence ?case using wte'
by(blast intro:WTrtFAccNT widen_refl) }
moreover
{ fix C' assume U: "U = Class C'" and C'subC: "P ⊢ C' ≼⇧* C"
from has_field_mono[OF has C'subC] wte' U
have ?case by(blast intro:WTrtFAcc) }
ultimately have ?case using UsubC by(simp add: widen_Class) blast }
moreover
{ assume "P,E,h ⊢ e : NT"
hence "P,E,h' ⊢ e' : NT" using IH[OF conf] by fastforce
hence ?case by(fastforce intro:WTrtFAccNT widen_refl) }
ultimately show ?case using wt by blast
next
case RedFAcc thus ?case
by(fastforce simp:sconf_def hconf_def oconf_def conf_def has_field_def
dest:has_fields_fun)
next
case RedFAccNull thus ?case
by(fastforce intro: widen_refl WTThrow[OF WTVal] elim!: typeof_NullPointer
simp: sconf_def hconf_def)
next
case (FAssRed1 e h l e' h' l' F D e⇩2)
have red: "P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩"
and IH: "⋀E T. ⟦P,E ⊢ (h,l) √; P,E,h ⊢ e : T⟧
⟹ ∃U. P,E,h' ⊢ e' : U ∧ P ⊢ U ≤ T"
and conf: "P,E ⊢ (h,l) √" and wt: "P,E,h ⊢ e∙F{D}:=e⇩2 : T" by fact+
from wt have void: "T = Void" by blast
{ assume "P,E,h ⊢ e : NT"
hence "P,E,h' ⊢ e' : NT" using IH[OF conf] by fastforce
moreover obtain T⇩2 where "P,E,h ⊢ e⇩2 : T⇩2" using wt by auto
from this red_hext_incr[OF red] have "P,E,h' ⊢ e⇩2 : T⇩2"
by(rule WTrt_hext_mono)
ultimately have ?case using void by(blast intro!:WTrtFAssNT)
}
moreover
{ fix C TF T⇩2 assume wt⇩1: "P,E,h ⊢ e : Class C" and wt⇩2: "P,E,h ⊢ e⇩2 : T⇩2"
and has: "P ⊢ C has F:TF in D" and sub: "P ⊢ T⇩2 ≤ TF"
obtain U where wt⇩1': "P,E,h' ⊢ e' : U" and UsubC: "P ⊢ U ≤ Class C"
using IH[OF conf wt⇩1] by blast
have wt⇩2': "P,E,h' ⊢ e⇩2 : T⇩2"
by(rule WTrt_hext_mono[OF wt⇩2 red_hext_incr[OF red]])
{ assume "U = NT" with wt⇩1' wt⇩2' void have ?case
by(blast intro!:WTrtFAssNT) }
moreover
{ fix C' assume UClass: "U = Class C'" and "subclass": "P ⊢ C' ≼⇧* C"
have "P,E,h' ⊢ e' : Class C'" using wt⇩1' UClass by auto
moreover have "P ⊢ C' has F:TF in D"
by(rule has_field_mono[OF has "subclass"])
ultimately have ?case using wt⇩2' sub void by(blast intro:WTrtFAss) }
ultimately have ?case using UsubC by(auto simp add:widen_Class) }
ultimately show ?case using wt by blast
next
case (FAssRed2 e⇩2 h l e⇩2' h' l' v F D)
have red: "P ⊢ ⟨e⇩2,(h,l)⟩ → ⟨e⇩2',(h',l')⟩"
and IH: "⋀E T. ⟦P,E ⊢ (h,l) √; P,E,h ⊢ e⇩2 : T⟧
⟹ ∃U. P,E,h' ⊢ e⇩2' : U ∧ P ⊢ U ≤ T"
and conf: "P,E ⊢ (h,l) √" and wt: "P,E,h ⊢ Val v∙F{D}:=e⇩2 : T" by fact+
from wt have [simp]: "T = Void" by auto
from wt show ?case
proof (rule WTrt_elim_cases)
fix C TF T⇩2
assume wt⇩1: "P,E,h ⊢ Val v : Class C"
and has: "P ⊢ C has F:TF in D"
and wt⇩2: "P,E,h ⊢ e⇩2 : T⇩2" and TsubTF: "P ⊢ T⇩2 ≤ TF"
have wt⇩1': "P,E,h' ⊢ Val v : Class C"
by(rule WTrt_hext_mono[OF wt⇩1 red_hext_incr[OF red]])
obtain T⇩2' where wt⇩2': "P,E,h' ⊢ e⇩2' : T⇩2'" and T'subT: "P ⊢ T⇩2' ≤ T⇩2"
using IH[OF conf wt⇩2] by blast
have "P,E,h' ⊢ Val v∙F{D}:=e⇩2' : Void"
by(rule WTrtFAss[OF wt⇩1' has wt⇩2' widen_trans[OF T'subT TsubTF]])
thus ?case by auto
next
fix T⇩2 assume null: "P,E,h ⊢ Val v : NT" and wt⇩2: "P,E,h ⊢ e⇩2 : T⇩2"
from null have "v = Null" by simp
moreover
obtain T⇩2' where "P,E,h' ⊢ e⇩2' : T⇩2' ∧ P ⊢ T⇩2' ≤ T⇩2"
using IH[OF conf wt⇩2] by blast
ultimately show ?thesis by(fastforce intro:WTrtFAssNT)
qed
next
case RedFAss thus ?case by(auto simp del:fun_upd_apply)
next
case RedFAssNull thus ?case
by(fastforce intro: WTThrow[OF WTVal] elim!:typeof_NullPointer simp:sconf_def hconf_def)
next
case (CallObj e h l e' h' l' M es)
have red: "P ⊢ ⟨e,(h,l)⟩ → ⟨e',(h',l')⟩"
and IH: "⋀E T. ⟦P,E ⊢ (h,l) √; P,E,h ⊢ e : T⟧
⟹ ∃U. P,E,h' ⊢ e' : U ∧ P ⊢ U ≤ T"
and conf: "P,E ⊢ (h,l) √" and wt: "P,E,h ⊢ e∙M(es) : T" by fact+
{ assume "P,E,h ⊢ e:NT"
hence "P,E,h' ⊢ e' : NT" using IH[OF conf] by fastforce
moreover
fix Ts assume wtes: "P,E,h ⊢ es [:] Ts"
have "P,E,h' ⊢ es [:] Ts"
by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
ultimately have ?case by(blast intro!:WTrtCallNT) }
moreover
{ fix C D Ts Us pns body
assume wte: "P,E,h ⊢ e : Class C"
and "method": "P ⊢ C sees M:Ts→T = (pns,body) in D"
and wtes: "P,E,h ⊢ es [:] Us" and subs: "P ⊢ Us [≤] Ts"
obtain U where wte': "P,E,h' ⊢ e' : U" and UsubC: "P ⊢ U ≤ Class C"
using IH[OF conf wte] by blast
{ assume "U = NT"
moreover have "P,E,h' ⊢ es [:] Us"
by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
ultimately have ?case using wte' by(blast intro!:WTrtCallNT) }
moreover
{ fix C' assume UClass: "U = Class C'" and "subclass": "P ⊢ C' ≼⇧* C"
have "P,E,h' ⊢ e' : Class C'" using wte' UClass by auto
moreover obtain Ts' T' pns' body' D'
where method': "P ⊢ C' sees M:Ts'→T' = (pns',body') in D'"
and subs': "P ⊢ Ts [≤] Ts'" and sub': "P ⊢ T' ≤ T"
using Call_lemma[OF "method" "subclass" wf] by fast
moreover have "P,E,h' ⊢ es [:] Us"
by(rule WTrts_hext_mono[OF wtes red_hext_incr[OF red]])
ultimately have ?case
using subs by(blast intro:WTrtCall rtrancl_trans widens_trans) }
ultimately have ?case using UsubC by(auto simp add:widen_Class) }
ultimately show ?case using wt by auto
next
case (CallParams es h l es' h' l' v M)
have reds: "P ⊢ ⟨es,(h,l)⟩ [→] ⟨es',(h',l')⟩"
and IH: "⋀E Ts. ⟦P,E ⊢ (h,l) √; P,E,h ⊢ es [:] Ts⟧
⟹ ∃Us. P,E,h' ⊢ es' [:] Us ∧ P ⊢ Us [≤] Ts"
and conf: "P,E ⊢ (h,l) √" and wt: "P,E,h ⊢ Val v∙M(es) : T" by fact+
from wt show ?case
proof (rule WTrt_elim_cases)
fix C D Ts Us pns body
assume wte: "P,E,h ⊢ Val v : Class C"
and "P ⊢ C sees M:Ts→T = (pns,body) in D"
and wtes: "P,E,h ⊢ es [:] Us" and "P ⊢ Us [≤] Ts"
moreover have "P,E,h' ⊢ Val v : Class C"
by(rule WTrt_hext_mono[OF wte reds_hext_incr[OF reds]])
moreover
obtain Us' where "P,E,h' ⊢ es' [:] Us' ∧ P ⊢ Us' [≤] Us"
using IH[OF conf wtes] by blast
ultimately show ?thesis by(blast intro:WTrtCall widens_trans)
next
fix Us
assume null: "P,E,h ⊢ Val v : NT" and wtes: "P,E,h ⊢ es [:] Us"
from null have "v = Null" by simp
moreover
obtain Us' where "P,E,h' ⊢ es' [:] Us' ∧ P ⊢ Us' [≤] Us"
using IH[OF conf wtes] by blast
ultimately show ?thesis by(fastforce intro:WTrtCallNT)
qed
next
case RedCallNull thus ?case
by(fastforce intro: WTThrow[OF WTVal] elim!:typeof_NullPointer simp: sconf_def hconf_def)
next
case (InitBlockRed e h l V v e' h' l' v' T E T')
have red: "P ⊢ ⟨e, (h,l(V↦v))⟩ → ⟨e',(h',l')⟩"
and IH: "⋀E T. ⟦P,E ⊢ (h,l(V↦v)) √; P,E,h ⊢ e : T⟧
⟹ ∃U. P,E,h' ⊢ e' : U ∧ P ⊢ U ≤ T"
and v': "l' V = Some v'" and conf: "P,E ⊢ (h,l) √"
and wt: "P,E,h ⊢ {V:T := Val v; e} : T'" by fact+
from wt obtain T⇩1 where wt⇩1: "typeof⇘h⇙ v = Some T⇩1"
and T1subT: "P ⊢ T⇩1 ≤ T" and wt⇩2: "P,E(V↦T),h ⊢ e : T'" by auto
have lconf⇩2: "P,h ⊢ l(V↦v) (:≤) E(V↦T)" using conf wt⇩1 T1subT
by(simp add:sconf_def lconf_upd2 conf_def)
have "∃T⇩1'. typeof⇘h'⇙ v' = Some T⇩1' ∧ P ⊢ T⇩1' ≤ T"
using v' red_preserves_lconf[OF red wt⇩2 lconf⇩2]
by(fastforce simp:lconf_def conf_def)
with IH conf lconf⇩2 wt⇩2 show ?case by (fastforce simp add:sconf_def)
next
case BlockRedNone thus ?case
by(auto simp del:fun_upd_apply)(fastforce simp:sconf_def lconf_def)
next
case (BlockRedSome e h l V e' h' l' v T E Te)
have red: "P ⊢ ⟨e,(h,l(V:=None))⟩ → ⟨e',(h',l')⟩"
and IH: "⋀E T. ⟦P,E ⊢ (h,l(V:=None)) √; P,E,h ⊢ e : T⟧
⟹ ∃T'. P,E,h' ⊢ e' : T' ∧ P ⊢ T' ≤ T"
and Some: "l' V = Some v" and conf: "P,E ⊢ (h,l) √"
and wt: "P,E,h ⊢ {V:T; e} : Te" by fact+
obtain Te' where IH': "P,E(V↦T),h' ⊢ e' : Te' ∧ P ⊢ Te' ≤ Te"
using IH conf wt by(fastforce simp:sconf_def lconf_def)
have "P,h' ⊢ l' (:≤) E(V↦T)" using conf wt
by(fastforce intro:red_preserves_lconf[OF red] simp:sconf_def lconf_def)
hence "P,h' ⊢ v :≤ T" using Some by(fastforce simp:lconf_def)
with IH' show ?case
by(fastforce simp:sconf_def conf_def fun_upd_same simp del:fun_upd_apply)
next
case SeqRed thus ?case
by auto (blast dest:WTrt_hext_mono[OF _ red_hext_incr])
next
case CondRed thus ?case
by auto (blast intro:WTrt_hext_mono[OF _ red_hext_incr])+
next
case ThrowRed thus ?case
by(auto simp:is_refT_def)(blast dest:widen_Class[THEN iffD1])+
next
case RedThrowNull thus ?case
by(fastforce intro: WTThrow[OF WTVal] elim!:typeof_NullPointer simp:sconf_def hconf_def)
next
case TryRed thus ?case
by auto (blast intro:widen_trans WTrt_hext_mono[OF _ red_hext_incr])
next
case RedTryFail thus ?case
by(fastforce intro: WTrtThrow[OF WTrtVal] simp:sconf_def hconf_def)
next
case ListRed1 thus ?case
by(fastforce dest: WTrts_hext_mono[OF _ red_hext_incr])
next
case ListRed2 thus ?case
by(fastforce dest: hext_typeof_mono[OF reds_hext_incr])
qed fastforce+
corollary subject_reduction:
"⟦ wf_J_prog P; P ⊢ ⟨e,s⟩ → ⟨e',s'⟩; P,E ⊢ s √; P,E,hp s ⊢ e:T ⟧
⟹ ∃T'. P,E,hp s' ⊢ e':T' ∧ P ⊢ T' ≤ T"
by(cases s, cases s', fastforce dest:subject_reduction2)
corollary subjects_reduction:
"⟦ wf_J_prog P; P ⊢ ⟨es,s⟩ [→] ⟨es',s'⟩; P,E ⊢ s √; P,E,hp s ⊢ es[:]Ts ⟧
⟹ ∃Ts'. P,E,hp s' ⊢ es'[:]Ts' ∧ P ⊢ Ts' [≤] Ts"
by(cases s, cases s', fastforce dest:subjects_reduction2)
subsection ‹Lifting to ‹→*››
text‹Now all these preservation lemmas are first lifted to the transitive
closure \dots›
lemma Red_preserves_sconf:
assumes wf: "wf_J_prog P" and Red: "P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩"
shows "⋀T. ⟦ P,E,hp s ⊢ e : T; P,E ⊢ s √ ⟧ ⟹ P,E ⊢ s' √"
using Red
proof (induct rule:converse_rtrancl_induct2)
case refl show ?case by fact
next
case step thus ?case
by(blast intro:red_preserves_sconf dest: subject_reduction[OF wf])
qed
lemma Red_preserves_defass:
assumes wf: "wf_J_prog P" and reds: "P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩"
shows "𝒟 e ⌊dom(lcl s)⌋ ⟹ 𝒟 e' ⌊dom(lcl s')⌋"
using reds
proof (induct rule:converse_rtrancl_induct2)
case refl thus ?case .
next
case (step e s e' s') thus ?case
by(cases s,cases s')(auto dest:red_preserves_defass[OF wf])
qed
lemma Red_preserves_type:
assumes wf: "wf_J_prog P" and Red: "P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩"
shows "!!T. ⟦ P,E ⊢ s√; P,E,hp s ⊢ e:T ⟧
⟹ ∃T'. P ⊢ T' ≤ T ∧ P,E,hp s' ⊢ e':T'"
using Red
proof (induct rule:converse_rtrancl_induct2)
case refl thus ?case by blast
next
case step thus ?case
by(blast intro:widen_trans red_preserves_sconf
dest:subject_reduction[OF wf])
qed
subsection ‹Lifting to ‹⇒››
text‹\dots and now to the big step semantics, just for fun.›
lemma eval_preserves_sconf:
"⟦ wf_J_prog P; P ⊢ ⟨e,s⟩ ⇒ ⟨e',s'⟩; P,E ⊢ e::T; P,E ⊢ s√ ⟧ ⟹ P,E ⊢ s'√"
by(blast intro:Red_preserves_sconf big_by_small WT_implies_WTrt wf_prog_wwf_prog)
lemma eval_preserves_type: assumes wf: "wf_J_prog P"
shows "⟦ P ⊢ ⟨e,s⟩ ⇒ ⟨e',s'⟩; P,E ⊢ s√; P,E ⊢ e::T ⟧
⟹ ∃T'. P ⊢ T' ≤ T ∧ P,E,hp s' ⊢ e':T'"
by(blast dest:big_by_small[OF wf_prog_wwf_prog[OF wf]]
WT_implies_WTrt Red_preserves_type[OF wf])
subsection "The final polish"
text‹The above preservation lemmas are now combined and packed nicely.›
definition wf_config :: "J_prog ⇒ env ⇒ state ⇒ expr ⇒ ty ⇒ bool" ("_,_,_ ⊢ _ : _ √" [51,0,0,0,0]50)
where
"P,E,s ⊢ e:T √ ≡ P,E ⊢ s √ ∧ P,E,hp s ⊢ e:T"
theorem Subject_reduction: assumes wf: "wf_J_prog P"
shows "P ⊢ ⟨e,s⟩ → ⟨e',s'⟩ ⟹ P,E,s ⊢ e : T √
⟹ ∃T'. P,E,s' ⊢ e' : T' √ ∧ P ⊢ T' ≤ T"
by(force simp add: wf_config_def
elim:red_preserves_sconf dest:subject_reduction[OF wf])
theorem Subject_reductions:
assumes wf: "wf_J_prog P" and reds: "P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩"
shows "⋀T. P,E,s ⊢ e:T √ ⟹ ∃T'. P,E,s' ⊢ e':T' √ ∧ P ⊢ T' ≤ T"
using reds
proof (induct rule:converse_rtrancl_induct2)
case refl thus ?case by blast
next
case step thus ?case
by(blast dest:Subject_reduction[OF wf] intro:widen_trans)
qed
corollary Progress: assumes wf: "wf_J_prog P"
shows "⟦ P,E,s ⊢ e : T √; 𝒟 e ⌊dom(lcl s)⌋; ¬ final e ⟧ ⟹ ∃e' s'. P ⊢ ⟨e,s⟩ → ⟨e',s'⟩"
using progress[OF wf_prog_wwf_prog[OF wf]]
by(auto simp:wf_config_def sconf_def)
corollary TypeSafety:
"⟦ wf_J_prog P; P,E ⊢ s √; P,E ⊢ e::T; 𝒟 e ⌊dom(lcl s)⌋;
P ⊢ ⟨e,s⟩ →* ⟨e',s'⟩; ¬(∃e'' s''. P ⊢ ⟨e',s'⟩ → ⟨e'',s''⟩) ⟧
⟹ (∃v. e' = Val v ∧ P,hp s' ⊢ v :≤ T) ∨
(∃a. e' = Throw a ∧ a ∈ dom(hp s'))"
apply(subgoal_tac " P,E,s ⊢ e:T √")
prefer 2
apply(fastforce simp:wf_config_def dest:WT_implies_WTrt)
apply(frule (2) Subject_reductions)
apply(erule exE conjE)+
apply(frule (2) Red_preserves_defass)
apply(subgoal_tac "final e'")
prefer 2
apply(blast dest: Progress)
apply (fastforce simp:wf_config_def final_def conf_def dest: Progress)
done
end
Theory Annotate
section ‹Program annotation›
theory Annotate imports WellType begin
abbreviation (output)
unanFAcc :: "expr ⇒ vname ⇒ expr" ("(_∙_)" [10,10] 90) where
"unanFAcc e F == FAcc e F []"
abbreviation (output)
unanFAss :: "expr ⇒ vname ⇒ expr ⇒ expr" ("(_∙_ := _)" [10,0,90] 90) where
"unanFAss e F e' == FAss e F [] e'"
inductive
Anno :: "[J_prog,env, expr , expr] ⇒ bool"
("_,_ ⊢ _ ↝ _" [51,0,0,51]50)
and Annos :: "[J_prog,env, expr list, expr list] ⇒ bool"
("_,_ ⊢ _ [↝] _" [51,0,0,51]50)
for P :: J_prog
where
AnnoNew: "P,E ⊢ new C ↝ new C"
| AnnoCast: "P,E ⊢ e ↝ e' ⟹ P,E ⊢ Cast C e ↝ Cast C e'"
| AnnoVal: "P,E ⊢ Val v ↝ Val v"
| AnnoVarVar: "E V = ⌊T⌋ ⟹ P,E ⊢ Var V ↝ Var V"
| AnnoVarField: "⟦ E V = None; E this = ⌊Class C⌋; P ⊢ C sees V:T in D ⟧
⟹ P,E ⊢ Var V ↝ Var this∙V{D}"
| AnnoBinOp:
"⟦ P,E ⊢ e1 ↝ e1'; P,E ⊢ e2 ↝ e2' ⟧
⟹ P,E ⊢ e1 «bop» e2 ↝ e1' «bop» e2'"
| AnnoLAssVar:
"⟦ E V = ⌊T⌋; P,E ⊢ e ↝ e' ⟧ ⟹ P,E ⊢ V:=e ↝ V:=e'"
| AnnoLAssField:
"⟦ E V = None; E this = ⌊Class C⌋; P ⊢ C sees V:T in D; P,E ⊢ e ↝ e' ⟧
⟹ P,E ⊢ V:=e ↝ Var this∙V{D} := e'"
| AnnoFAcc:
"⟦ P,E ⊢ e ↝ e'; P,E ⊢ e' :: Class C; P ⊢ C sees F:T in D ⟧
⟹ P,E ⊢ e∙F{[]} ↝ e'∙F{D}"
| AnnoFAss: "⟦ P,E ⊢ e1 ↝ e1'; P,E ⊢ e2 ↝ e2';
P,E ⊢ e1' :: Class C; P ⊢ C sees F:T in D ⟧
⟹ P,E ⊢ e1∙F{[]} := e2 ↝ e1'∙F{D} := e2'"
| AnnoCall:
"⟦ P,E ⊢ e ↝ e'; P,E ⊢ es [↝] es' ⟧
⟹ P,E ⊢ Call e M es ↝ Call e' M es'"
| AnnoBlock:
"P,E(V ↦ T) ⊢ e ↝ e' ⟹ P,E ⊢ {V:T; e} ↝ {V:T; e'}"
| AnnoComp: "⟦ P,E ⊢ e1 ↝ e1'; P,E ⊢ e2 ↝ e2' ⟧
⟹ P,E ⊢ e1;;e2 ↝ e1';;e2'"
| AnnoCond: "⟦ P,E ⊢ e ↝ e'; P,E ⊢ e1 ↝ e1'; P,E ⊢ e2 ↝ e2' ⟧
⟹ P,E ⊢ if (e) e1 else e2 ↝ if (e') e1' else e2'"
| AnnoLoop: "⟦ P,E ⊢ e ↝ e'; P,E ⊢ c ↝ c' ⟧
⟹ P,E ⊢ while (e) c ↝ while (e') c'"
| AnnoThrow: "P,E ⊢ e ↝ e' ⟹ P,E ⊢ throw e ↝ throw e'"
| AnnoTry: "⟦ P,E ⊢ e1 ↝ e1'; P,E(V ↦ Class C) ⊢ e2 ↝ e2' ⟧
⟹ P,E ⊢ try e1 catch(C V) e2 ↝ try e1' catch(C V) e2'"
| AnnoNil: "P,E ⊢ [] [↝] []"
| AnnoCons: "⟦ P,E ⊢ e ↝ e'; P,E ⊢ es [↝] es' ⟧
⟹ P,E ⊢ e#es [↝] e'#es'"
end
Theory Examples
section ‹Example Expressions›
theory Examples imports Expr begin
definition classObject::"J_mb cdecl"
where
"classObject == (''Object'','''',[],[])"
definition classI :: "J_mb cdecl"
where
"classI ==
(''I'', Object,
[],
[(''mult'',[Integer,Integer],Integer,[''i'',''j''],
if (Var ''i'' «Eq» Val(Intg 0)) (Val(Intg 0))
else Var ''j'' «Add»
Var this ∙ ''mult''([Var ''i'' «Add» Val(Intg (- 1)),Var ''j'']))
])"
definition classL :: "J_mb cdecl"
where
"classL ==
(''L'', Object,
[(''F'',Integer), (''N'',Class ''L'')],
[(''app'',[Class ''L''],Void,[''l''],
if (Var this ∙ ''N''{''L''} «Eq» null)
(Var this ∙ ''N''{''L''} := Var ''l'')
else (Var this ∙ ''N''{''L''}) ∙ ''app''([Var ''l'']))
])"
definition testExpr_BuildList :: "expr"
where
"testExpr_BuildList ==
{''l1'':Class ''L'' := new ''L'';
Var ''l1''∙''F''{''L''} := Val(Intg 1);;
{''l2'':Class ''L'' := new ''L'';
Var ''l2''∙ ''F''{''L''} := Val(Intg 2);;
{''l3'':Class ''L'' := new ''L'';
Var ''l3''∙ ''F''{''L''} := Val(Intg 3);;
{''l4'':Class ''L'' := new ''L'';
Var ''l4''∙ ''F''{''L''} := Val(Intg 4);;
Var ''l1''∙''app''([Var ''l2'']);;
Var ''l1''∙''app''([Var ''l3'']);;
Var ''l1''∙''app''([Var ''l4''])}}}}"
definition testExpr1 ::"expr"
where
"testExpr1 == Val(Intg 5)"
definition testExpr2 ::"expr"
where
"testExpr2 == BinOp (Val(Intg 5)) Add (Val(Intg 6))"
definition testExpr3 ::"expr"
where
"testExpr3 == BinOp (Var ''V'') Add (Val(Intg 6))"
definition testExpr4 ::"expr"
where
"testExpr4 == ''V'' := Val(Intg 6)"
definition testExpr5 ::"expr"
where
"testExpr5 == new ''Object'';; {''V'':(Class ''C'') := new ''C''; Var ''V''∙''F''{''C''} := Val(Intg 42)}"
definition testExpr6 ::"expr"
where
"testExpr6 == {''V'':(Class ''I'') := new ''I''; Var ''V''∙''mult''([Val(Intg 40),Val(Intg 4)])}"
definition mb_isNull:: "expr"
where
"mb_isNull == Var this ∙ ''test''{''A''} «Eq» null "
definition mb_add:: "expr"
where
"mb_add == (Var this ∙ ''int''{''A''} :=( Var this ∙ ''int''{''A''} «Add» Var ''i''));; (Var this ∙ ''int''{''A''})"
definition mb_mult_cond:: "expr"
where
"mb_mult_cond == (Var ''j'' «Eq» Val (Intg 0)) «Eq» Val (Bool False)"
definition mb_mult_block:: "expr"
where
"mb_mult_block == ''temp'':=(Var ''temp'' «Add» Var ''i'');;''j'':=(Var ''j'' «Add» Val (Intg (- 1)))"
definition mb_mult:: "expr"
where
"mb_mult == {''temp'':Integer:=Val (Intg 0); While (mb_mult_cond) mb_mult_block;; ( Var this ∙ ''int''{''A''} := Var ''temp'';; Var ''temp'' )}"
definition classA:: "J_mb cdecl"
where
"classA ==
(''A'', Object,
[(''int'',Integer),
(''test'',Class ''A'') ],
[(''isNull'',[],Boolean,[], mb_isNull),
(''add'',[Integer],Integer,[''i''], mb_add),
(''mult'',[Integer,Integer],Integer,[''i'',''j''], mb_mult) ])"
definition testExpr_ClassA:: "expr"
where
"testExpr_ClassA ==
{''A1'':Class ''A'':= new ''A'';
{''A2'':Class ''A'':= new ''A'';
{''testint'':Integer:= Val (Intg 5);
(Var ''A2''∙ ''int''{''A''} := (Var ''A1''∙ ''add''([Var ''testint''])));;
(Var ''A2''∙ ''int''{''A''} := (Var ''A1''∙ ''add''([Var ''testint''])));;
Var ''A2''∙ ''mult''([Var ''A2''∙ ''int''{''A''}, Var ''testint'']) }}}"
end
Theory execute_Bigstep
section ‹Code Generation For BigStep›
theory execute_Bigstep
imports
BigStep Examples
"HOL-Library.Code_Target_Numeral"
begin
inductive map_val :: "expr list ⇒ val list ⇒ bool"
where
Nil: "map_val [] []"
| Cons: "map_val xs ys ⟹ map_val (Val y # xs) (y # ys)"
inductive map_val2 :: "expr list ⇒ val list ⇒ expr list ⇒ bool"
where
Nil: "map_val2 [] [] []"
| Cons: "map_val2 xs ys zs ⟹ map_val2 (Val y # xs) (y # ys) zs"
| Throw: "map_val2 (throw e # xs) [] (throw e # xs)"
theorem map_val_conv: "(xs = map Val ys) = map_val xs ys"
proof -
have "⋀ys. xs = map Val ys ⟹ map_val xs ys"
apply (induct xs type:list)
apply (case_tac ys)
apply simp
apply (rule map_val.Nil)
apply simp
apply (case_tac ys)
apply simp
apply simp
apply (rule map_val.Cons)
apply simp
done
moreover have "map_val xs ys ⟹ xs = map Val ys"
by (erule map_val.induct) simp+
ultimately show ?thesis ..
qed
theorem map_val2_conv:
"(xs = map Val ys @ throw e # zs) = map_val2 xs ys (throw e # zs)"
proof -
have "⋀ys. xs = map Val ys @ throw e # zs ⟹ map_val2 xs ys (throw e # zs)"
apply (induct xs type:list)
apply (case_tac ys)
apply simp
apply simp
apply simp
apply (case_tac ys)
apply simp
apply (rule map_val2.Throw)
apply simp
apply (rule map_val2.Cons)
apply simp
done
moreover have "map_val2 xs ys (throw e # zs) ⟹ xs = map Val ys @ throw e # zs"
by (erule map_val2.induct) simp+
ultimately show ?thesis ..
qed
lemma CallNull2:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩; P ⊢ ⟨ps,s⇩1⟩ [⇒] ⟨evs,s⇩2⟩; map_val evs vs ⟧
⟹ P ⊢ ⟨e∙M(ps),s⇩0⟩ ⇒ ⟨THROW NullPointer,s⇩2⟩"
apply(rule CallNull, assumption+)
apply(simp add: map_val_conv[symmetric])
done
lemma CallParamsThrow2:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨Val v,s⇩1⟩; P ⊢ ⟨es,s⇩1⟩ [⇒] ⟨evs,s⇩2⟩;
map_val2 evs vs (throw ex # es'') ⟧
⟹ P ⊢ ⟨e∙M(es),s⇩0⟩ ⇒ ⟨throw ex,s⇩2⟩"
apply(rule eval_evals.CallParamsThrow, assumption+)
apply(simp add: map_val2_conv[symmetric])
done
lemma Call2:
"⟦ P ⊢ ⟨e,s⇩0⟩ ⇒ ⟨addr a,s⇩1⟩; P ⊢ ⟨ps,s⇩1⟩ [⇒] ⟨evs,(h⇩2,l⇩2)⟩;
map_val evs vs;
h⇩2 a = Some(C,fs); P ⊢ C sees M:Ts→T = (pns,body) in D;
length vs = length pns; l⇩2' = [this↦Addr a, pns[↦]vs];
P ⊢ ⟨body,(h⇩2,l⇩2')⟩ ⇒ ⟨e',(h⇩3,l⇩3)⟩ ⟧
⟹ P ⊢ ⟨e∙M(ps),s⇩0⟩ ⇒ ⟨e',(h⇩3,l⇩2)⟩"
apply(rule Call, assumption+)
apply(simp add: map_val_conv[symmetric])
apply assumption+
done
code_pred
(modes: i ⇒ o ⇒ bool)
map_val
.
code_pred
(modes: i ⇒ o ⇒ o ⇒ bool)
map_val2
.
lemmas [code_pred_intro] =
eval_evals.New eval_evals.NewFail
eval_evals.Cast eval_evals.CastNull eval_evals.CastFail eval_evals.CastThrow
eval_evals.Val eval_evals.Var
eval_evals.BinOp eval_evals.BinOpThrow1 eval_evals.BinOpThrow2
eval_evals.LAss eval_evals.LAssThrow
eval_evals.FAcc eval_evals.FAccNull eval_evals.FAccThrow
eval_evals.FAss eval_evals.FAssNull
eval_evals.FAssThrow1 eval_evals.FAssThrow2
eval_evals.CallObjThrow
declare CallNull2 [code_pred_intro CallNull2]
declare CallParamsThrow2 [code_pred_intro CallParamsThrow2]
declare Call2 [code_pred_intro Call2]
lemmas [code_pred_intro] =
eval_evals.Block
eval_evals.Seq eval_evals.SeqThrow
eval_evals.CondT eval_evals.CondF eval_evals.CondThrow
eval_evals.WhileF eval_evals.WhileT
eval_evals.WhileCondThrow
declare eval_evals.WhileBodyThrow [code_pred_intro WhileBodyThrow2]
lemmas [code_pred_intro] =
eval_evals.Throw eval_evals.ThrowNull
eval_evals.ThrowThrow
eval_evals.Try eval_evals.TryCatch eval_evals.TryThrow
eval_evals.Nil eval_evals.Cons eval_evals.ConsThrow
code_pred
(modes: i ⇒ i ⇒ i ⇒ o ⇒ o ⇒ bool as execute)
eval
proof -
case eval
from eval.prems show thesis
proof(cases (no_simp))
case CallNull thus ?thesis
by(rule eval.CallNull2[OF refl])(simp add: map_val_conv[symmetric])
next
case CallParamsThrow thus ?thesis
by(rule eval.CallParamsThrow2[OF refl])(simp add: map_val2_conv[symmetric])
next
case Call thus ?thesis
by -(rule eval.Call2[OF refl], simp_all add: map_val_conv[symmetric])
next
case WhileBodyThrow thus ?thesis by(rule eval.WhileBodyThrow2[OF refl])
qed(assumption|erule (4) eval.that[OF refl]|erule (3) eval.that[OF refl])+
next
case evals
from evals.prems show thesis
by(cases (no_simp))(assumption|erule (3) evals.that[OF refl])+
qed
notation execute ("_ ⊢ ((1⟨_,/_⟩) ⇒/ ⟨'_, '_⟩)" [51,0,0] 81)
definition "test1 = [] ⊢ ⟨testExpr1,(Map.empty,Map.empty)⟩ ⇒ ⟨_,_⟩"
definition "test2 = [] ⊢ ⟨testExpr2,(Map.empty,Map.empty)⟩ ⇒ ⟨_,_⟩"
definition "test3 = [] ⊢ ⟨testExpr3,(Map.empty,Map.empty(''V''↦Intg 77))⟩ ⇒ ⟨_,_⟩"
definition "test4 = [] ⊢ ⟨testExpr4,(Map.empty,Map.empty)⟩ ⇒ ⟨_,_⟩"
definition "test5 = [(''Object'',('''',[],[])),(''C'',(''Object'',[(''F'',Integer)],[]))] ⊢ ⟨testExpr5,(Map.empty,Map.empty)⟩ ⇒ ⟨_,_⟩"
definition "test6 = [(''Object'',('''',[],[])), classI] ⊢ ⟨testExpr6,(Map.empty,Map.empty)⟩ ⇒ ⟨_,_⟩"
definition "V = ''V''"
definition "C = ''C''"
definition "F = ''F''"
ML_val ‹
val SOME ((@{code Val} (@{code Intg} (@{code int_of_integer} 5)), _), _) = Predicate.yield @{code test1};
val SOME ((@{code Val} (@{code Intg} (@{code int_of_integer} 11)), _), _) = Predicate.yield @{code test2};
val SOME ((@{code Val} (@{code Intg} (@{code int_of_integer} 83)), _), _) = Predicate.yield @{code test3};
val SOME ((_, (_, l)), _) = Predicate.yield @{code test4};
val SOME (@{code Intg} (@{code int_of_integer} 6)) = l @{code V};
val SOME ((_, (h, _)), _) = Predicate.yield @{code test5};
val SOME (c, fs) = h (@{code nat_of_integer} 1);
val SOME (obj, _) = h (@{code nat_of_integer} 0);
val SOME (@{code Intg} i) = fs (@{code F}, @{code C});
@{assert} (c = @{code C} andalso obj = @{code Object} andalso i = @{code int_of_integer} 42);
val SOME ((@{code Val} (@{code Intg} (@{code int_of_integer} 160)), _), _) = Predicate.yield @{code test6};
›
definition "test7 = [classObject, classL] ⊢ ⟨testExpr_BuildList, (Map.empty,Map.empty)⟩ ⇒ ⟨_,_⟩"
definition "L = ''L''"
definition "N = ''N''"
ML_val ‹
val SOME ((_, (h, _)), _) = Predicate.yield @{code test7};
val SOME (_, fs1) = h (@{code nat_of_integer} 0);
val SOME (_, fs2) = h (@{code nat_of_integer} 1);
val SOME (_, fs3) = h (@{code nat_of_integer} 2);
val SOME (_, fs4) = h (@{code nat_of_integer} 3);
val F = @{code "F"};
val L = @{code "L"};
val N = @{code "N"};
@{assert} (fs1 (F, L) = SOME (@{code Intg} (@{code int_of_integer} 1)) andalso
fs1 (N, L) = SOME (@{code Addr} (@{code nat_of_integer} 1)) andalso
fs2 (F, L) = SOME (@{code Intg} (@{code int_of_integer} 2)) andalso
fs2 (N, L) = SOME (@{code Addr} (@{code nat_of_integer} 2)) andalso
fs3 (F, L) = SOME (@{code Intg} (@{code int_of_integer} 3)) andalso
fs3 (N, L) = SOME (@{code Addr} (@{code nat_of_integer} 3)) andalso
fs4 (F, L) = SOME (@{code Intg} (@{code int_of_integer} 4)) andalso
fs4 (N, L) = SOME @{code Null});
›
definition "test8 = [classObject, classA] ⊢ ⟨testExpr_ClassA, (Map.empty,Map.empty)⟩ ⇒ ⟨_,_⟩"
definition "i = ''int''"
definition "t = ''test''"
definition "A = ''A''"
ML_val ‹
val SOME ((_, (h, l)), _) = Predicate.yield @{code test8};
val SOME (_, fs1) = h (@{code nat_of_integer} 0);
val SOME (_, fs2) = h (@{code nat_of_integer} 1);
val i = @{code "i"};
val t = @{code "t"};
val A = @{code "A"};
@{assert} (fs1 (i, A) = SOME (@{code Intg} (@{code int_of_integer} 10)) andalso
fs1 (t, A) = SOME @{code Null} andalso
fs2 (i, A) = SOME (@{code Intg} (@{code int_of_integer} 50)) andalso
fs2 (t, A) = SOME @{code Null});
›
end
Theory execute_WellType
section ‹Code Generation For WellType›
theory execute_WellType
imports
WellType Examples
begin
lemma WTCond1:
"⟦P,E ⊢ e :: Boolean; P,E ⊢ e⇩1::T⇩1; P,E ⊢ e⇩2::T⇩2; P ⊢ T⇩1 ≤ T⇩2;
P ⊢ T⇩2 ≤ T⇩1 ⟶ T⇩2 = T⇩1 ⟧ ⟹ P,E ⊢ if (e) e⇩1 else e⇩2 :: T⇩2"
by (fastforce)
lemma WTCond2:
"⟦P,E ⊢ e :: Boolean; P,E ⊢ e⇩1::T⇩1; P,E ⊢ e⇩2::T⇩2; P ⊢ T⇩2 ≤ T⇩1;
P ⊢ T⇩1 ≤ T⇩2 ⟶ T⇩1 = T⇩2 ⟧ ⟹ P,E ⊢ if (e) e⇩1 else e⇩2 :: T⇩1"
by (fastforce)
lemmas [code_pred_intro] =
WT_WTs.WTNew
WT_WTs.WTCast
WT_WTs.WTVal
WT_WTs.WTVar
WT_WTs.WTBinOpEq
WT_WTs.WTBinOpAdd
WT_WTs.WTLAss
WT_WTs.WTFAcc
WT_WTs.WTFAss
WT_WTs.WTCall
WT_WTs.WTBlock
WT_WTs.WTSeq
declare
WTCond1 [code_pred_intro WTCond1]
WTCond2 [code_pred_intro WTCond2]
lemmas [code_pred_intro] =
WT_WTs.WTWhile
WT_WTs.WTThrow
WT_WTs.WTTry
WT_WTs.WTNil
WT_WTs.WTCons
code_pred
(modes: i ⇒ i ⇒ i ⇒ i ⇒ bool as type_check, i ⇒ i ⇒ i ⇒ o ⇒ bool as infer_type)
WT
proof -
case WT
from WT.prems show thesis
proof(cases (no_simp))
case (WTCond E e e1 T1 e2 T2 T)
from ‹x ⊢ T1 ≤ T2 ∨ x ⊢ T2 ≤ T1› show thesis
proof
assume "x ⊢ T1 ≤ T2"
with ‹x ⊢ T1 ≤ T2 ⟶ T = T2› have "T = T2" ..
from ‹xa = E› ‹xb = if (e) e1 else e2› ‹xc = T› ‹x,E ⊢ e :: Boolean›
‹x,E ⊢ e1 :: T1› ‹x,E ⊢ e2 :: T2› ‹x ⊢ T1 ≤ T2› ‹x ⊢ T2 ≤ T1 ⟶ T = T1›
show ?thesis unfolding ‹T = T2› by(rule WT.WTCond1[OF refl])
next
assume "x ⊢ T2 ≤ T1"
with ‹x ⊢ T2 ≤ T1 ⟶ T = T1› have "T = T1" ..
from ‹xa = E› ‹xb = if (e) e1 else e2› ‹xc = T› ‹x,E ⊢ e :: Boolean›
‹x,E ⊢ e1 :: T1› ‹x,E ⊢ e2 :: T2› ‹x ⊢ T2 ≤ T1› ‹x ⊢ T1 ≤ T2 ⟶ T = T2›
show ?thesis unfolding ‹T = T1› by(rule WT.WTCond2[OF refl])
qed
qed(assumption|erule (2) WT.that[OF refl])+
next
case WTs
from WTs.prems show thesis
by(cases (no_simp))(assumption|erule (2) WTs.that[OF refl])+
qed
notation infer_type ("_,_ ⊢ _ :: '_" [51,51,51]100)
definition test1 where "test1 = [],Map.empty ⊢ testExpr1 :: _"
definition test2 where "test2 = [], Map.empty ⊢ testExpr2 :: _"
definition test3 where "test3 = [], Map.empty(''V'' ↦ Integer) ⊢ testExpr3 :: _"
definition test4 where "test4 = [], Map.empty(''V'' ↦ Integer) ⊢ testExpr4 :: _"
definition test5 where "test5 = [classObject, (''C'',(''Object'',[(''F'',Integer)],[]))], Map.empty ⊢ testExpr5 :: _"
definition test6 where "test6 = [classObject, classI], Map.empty ⊢ testExpr6 :: _"
ML_val ‹
val SOME(@{code Integer}, _) = Predicate.yield @{code test1};
val SOME(@{code Integer}, _) = Predicate.yield @{code test2};
val SOME(@{code Integer}, _) = Predicate.yield @{code test3};
val SOME(@{code Void}, _) = Predicate.yield @{code test4};
val SOME(@{code Void}, _) = Predicate.yield @{code test5};
val SOME(@{code Integer}, _) = Predicate.yield @{code test6};
›
definition testmb_isNull where "testmb_isNull = [classObject, classA], Map.empty([this] [↦] [Class ''A'']) ⊢ mb_isNull :: _"
definition testmb_add where "testmb_add = [classObject, classA], Map.empty([this,''i''] [↦] [Class ''A'',Integer]) ⊢ mb_add :: _"
definition testmb_mult_cond where "testmb_mult_cond = [classObject, classA], Map.empty([this,''j''] [↦] [Class ''A'',Integer]) ⊢ mb_mult_cond :: _"
definition testmb_mult_block where "testmb_mult_block = [classObject, classA], Map.empty([this,''i'',''j'',''temp''] [↦] [Class ''A'',Integer,Integer,Integer]) ⊢ mb_mult_block :: _"
definition testmb_mult where "testmb_mult = [classObject, classA], Map.empty([this,''i'',''j''] [↦] [Class ''A'',Integer,Integer]) ⊢ mb_mult :: _"
ML_val ‹
val SOME(@{code Boolean}, _) = Predicate.yield @{code testmb_isNull};
val SOME(@{code Integer}, _) = Predicate.yield @{code testmb_add};
val SOME(@{code Boolean}, _) = Predicate.yield @{code testmb_mult_cond};
val SOME(@{code Void}, _) = Predicate.yield @{code testmb_mult_block};
val SOME(@{code Integer}, _) = Predicate.yield @{code testmb_mult};
›
definition test where "test = [classObject, classA], Map.empty ⊢ testExpr_ClassA :: _"
ML_val ‹
val SOME(@{code Integer}, _) = Predicate.yield @{code test};
›
end
Theory JVMState
chapter ‹Jinja Virtual Machine \label{cha:jvm}›
section ‹State of the JVM›
theory JVMState imports "../Common/Objects" begin
subsection ‹Frame Stack›
type_synonym
pc = nat
type_synonym
frame = "val list × val list × cname × mname × pc"
subsection ‹Runtime State›
type_synonym
jvm_state = "addr option × heap × frame list"
end
Theory JVMInstructions
section ‹Instructions of the JVM›
theory JVMInstructions imports JVMState begin
datatype
instr = Load nat
| Store nat
| Push val
| New cname
| Getfield vname cname
| Putfield vname cname
| Checkcast cname
| Invoke mname nat
| Return
| Pop
| IAdd
| Goto int
| CmpEq
| IfFalse int
| Throw
type_synonym
bytecode = "instr list"
type_synonym
ex_entry = "pc × pc × cname × pc × nat"
type_synonym
ex_table = "ex_entry list"
type_synonym
jvm_method = "nat × nat × bytecode × ex_table"
type_synonym
jvm_prog = "jvm_method prog"
end
Theory JVMExecInstr
section ‹JVM Instruction Semantics›
theory JVMExecInstr
imports JVMInstructions JVMState "../Common/Exceptions"
begin
primrec
exec_instr :: "[instr, jvm_prog, heap, val list, val list,
cname, mname, pc, frame list] => jvm_state"
where
exec_instr_Load:
"exec_instr (Load n) P h stk loc C⇩0 M⇩0 pc frs =
(None, h, ((loc ! n) # stk, loc, C⇩0, M⇩0, pc+1)#frs)"
| "exec_instr (Store n) P h stk loc C⇩0 M⇩0 pc frs =
(None, h, (tl stk, loc[n:=hd stk], C⇩0, M⇩0, pc+1)#frs)"
| exec_instr_Push:
"exec_instr (Push v) P h stk loc C⇩0 M⇩0 pc frs =
(None, h, (v # stk, loc, C⇩0, M⇩0, pc+1)#frs)"
| exec_instr_New:
"exec_instr (New C) P h stk loc C⇩0 M⇩0 pc frs =
(case new_Addr h of
None ⇒ (Some (addr_of_sys_xcpt OutOfMemory), h, (stk, loc, C⇩0, M⇩0, pc)#frs)
| Some a ⇒ (None, h(a↦blank P C), (Addr a#stk, loc, C⇩0, M⇩0, pc+1)#frs))"
| "exec_instr (Getfield F C) P h stk loc C⇩0 M⇩0 pc frs =
(let v = hd stk;
xp' = if v=Null then ⌊addr_of_sys_xcpt NullPointer⌋ else None;
(D,fs) = the(h(the_Addr v))
in (xp', h, (the(fs(F,C))#(tl stk), loc, C⇩0, M⇩0, pc+1)#frs))"
| "exec_instr (Putfield F C) P h stk loc C⇩0 M⇩0 pc frs =
(let v = hd stk;
r = hd (tl stk);
xp' = if r=Null then ⌊addr_of_sys_xcpt NullPointer⌋ else None;
a = the_Addr r;
(D,fs) = the (h a);
h' = h(a ↦ (D, fs((F,C) ↦ v)))
in (xp', h', (tl (tl stk), loc, C⇩0, M⇩0, pc+1)#frs))"
| "exec_instr (Checkcast C) P h stk loc C⇩0 M⇩0 pc frs =
(let v = hd stk;
xp' = if ¬cast_ok P C h v then ⌊addr_of_sys_xcpt ClassCast⌋ else None
in (xp', h, (stk, loc, C⇩0, M⇩0, pc+1)#frs))"
| exec_instr_Invoke:
"exec_instr (Invoke M n) P h stk loc C⇩0 M⇩0 pc frs =
(let ps = take n stk;
r = stk!n;
xp' = if r=Null then ⌊addr_of_sys_xcpt NullPointer⌋ else None;
C = fst(the(h(the_Addr r)));
(D,M',Ts,mxs,mxl⇩0,ins,xt)= method P C M;
f' = ([],[r]@(rev ps)@(replicate mxl⇩0 undefined),D,M,0)
in (xp', h, f'#(stk, loc, C⇩0, M⇩0, pc)#frs))"
| "exec_instr Return P h stk⇩0 loc⇩0 C⇩0 M⇩0 pc frs =
(if frs=[] then (None, h, []) else
let v = hd stk⇩0;
(stk,loc,C,m,pc) = hd frs;
n = length (fst (snd (method P C⇩0 M⇩0)))
in (None, h, (v#(drop (n+1) stk),loc,C,m,pc+1)#tl frs))"
| "exec_instr Pop P h stk loc C⇩0 M⇩0 pc frs =
(None, h, (tl stk, loc, C⇩0, M⇩0, pc+1)#frs)"
| "exec_instr IAdd P h stk loc C⇩0 M⇩0 pc frs =
(let i⇩2 = the_Intg (hd stk);
i⇩1 = the_Intg (hd (tl stk))
in (None, h, (Intg (i⇩1+i⇩2)#(tl (tl stk)), loc, C⇩0, M⇩0, pc+1)#frs))"
| "exec_instr (IfFalse i) P h stk loc C⇩0 M⇩0 pc frs =
(let pc' = if hd stk = Bool False then nat(int pc+i) else pc+1
in (None, h, (tl stk, loc, C⇩0, M⇩0, pc')#frs))"
| "exec_instr CmpEq P h stk loc C⇩0 M⇩0 pc frs =
(let v⇩2 = hd stk;
v⇩1 = hd (tl stk)
in (None, h, (Bool (v⇩1=v⇩2) # tl (tl stk), loc, C⇩0, M⇩0, pc+1)#frs))"
| exec_instr_Goto:
"exec_instr (Goto i) P h stk loc C⇩0 M⇩0 pc frs =
(None, h, (stk, loc, C⇩0, M⇩0, nat(int pc+i))#frs)"
| "exec_instr Throw P h stk loc C⇩0 M⇩0 pc frs =
(let xp' = if hd stk = Null then ⌊addr_of_sys_xcpt NullPointer⌋ else ⌊the_Addr(hd stk)⌋
in (xp', h, (stk, loc, C⇩0, M⇩0, pc)#frs))"
lemma exec_instr_Store:
"exec_instr (Store n) P h (v#stk) loc C⇩0 M⇩0 pc frs =
(None, h, (stk, loc[n:=v], C⇩0, M⇩0, pc+1)#frs)"
by simp
lemma exec_instr_Getfield:
"exec_instr (Getfield F C) P h (v#stk) loc C⇩0 M⇩0 pc frs =
(let xp' = if v=Null then ⌊addr_of_sys_xcpt NullPointer⌋ else None;
(D,fs) = the(h(the_Addr v))
in (xp', h, (the(fs(F,C))#stk, loc, C⇩0, M⇩0, pc+1)#frs))"
by simp
lemma exec_instr_Putfield:
"exec_instr (Putfield F C) P h (v#r#stk) loc C⇩0 M⇩0 pc frs =
(let xp' = if r=Null then ⌊addr_of_sys_xcpt NullPointer⌋ else None;
a = the_Addr r;
(D,fs) = the (h a);
h' = h(a ↦ (D, fs((F,C) ↦ v)))
in (xp', h', (stk, loc, C⇩0, M⇩0, pc+1)#frs))"
by simp
lemma exec_instr_Checkcast:
"exec_instr (Checkcast C) P h (v#stk) loc C⇩0 M⇩0 pc frs =
(let xp' = if ¬cast_ok P C h v then ⌊addr_of_sys_xcpt ClassCast⌋ else None
in (xp', h, (v#stk, loc, C⇩0, M⇩0, pc+1)#frs))"
by simp
lemma exec_instr_Return:
"exec_instr Return P h (v#stk⇩0) loc⇩0 C⇩0 M⇩0 pc frs =
(if frs=[] then (None, h, []) else
let (stk,loc,C,m,pc) = hd frs;
n = length (fst (snd (method P C⇩0 M⇩0)))
in (None, h, (v#(drop (n+1) stk),loc,C,m,pc+1)#tl frs))"
by simp
lemma exec_instr_IPop:
"exec_instr Pop P h (v#stk) loc C⇩0 M⇩0 pc frs =
(None, h, (stk, loc, C⇩0, M⇩0, pc+1)#frs)"
by simp
lemma exec_instr_IAdd:
"exec_instr IAdd P h (Intg i⇩2 # Intg i⇩1 # stk) loc C⇩0 M⇩0 pc frs =
(None, h, (Intg (i⇩1+i⇩2)#stk, loc, C⇩0, M⇩0, pc+1)#frs)"
by simp
lemma exec_instr_IfFalse:
"exec_instr (IfFalse i) P h (v#stk) loc C⇩0 M⇩0 pc frs =
(let pc' = if v = Bool False then nat(int pc+i) else pc+1
in (None, h, (stk, loc, C⇩0, M⇩0, pc')#frs))"
by simp
lemma exec_instr_CmpEq:
"exec_instr CmpEq P h (v⇩2#v⇩1#stk) loc C⇩0 M⇩0 pc frs =
(None, h, (Bool (v⇩1=v⇩2) # stk, loc, C⇩0, M⇩0, pc+1)#frs)"
by simp
lemma exec_instr_Throw:
"exec_instr Throw P h (v#stk) loc C⇩0 M⇩0 pc frs =
(let xp' = if v = Null then ⌊addr_of_sys_xcpt NullPointer⌋ else ⌊the_Addr v⌋
in (xp', h, (v#stk, loc, C⇩0, M⇩0, pc)#frs))"
by simp
end
Theory JVMExceptions
section ‹Exception handling in the JVM›
theory JVMExceptions imports JVMInstructions "../Common/Exceptions" begin
definition matches_ex_entry :: "'m prog ⇒ cname ⇒ pc ⇒ ex_entry ⇒ bool"
where
"matches_ex_entry P C pc xcp ≡
let (s, e, C', h, d) = xcp in
s ≤ pc ∧ pc < e ∧ P ⊢ C ≼⇧* C'"
primrec match_ex_table :: "'m prog ⇒ cname ⇒ pc ⇒ ex_table ⇒ (pc × nat) option"
where
"match_ex_table P C pc [] = None"
| "match_ex_table P C pc (e#es) = (if matches_ex_entry P C pc e
then Some (snd(snd(snd e)))
else match_ex_table P C pc es)"
abbreviation
ex_table_of :: "jvm_prog ⇒ cname ⇒ mname ⇒ ex_table" where
"ex_table_of P C M == snd (snd (snd (snd (snd (snd(method P C M))))))"
primrec find_handler :: "jvm_prog ⇒ addr ⇒ heap ⇒ frame list ⇒ jvm_state"
where
"find_handler P a h [] = (Some a, h, [])"
| "find_handler P a h (fr#frs) =
(let (stk,loc,C,M,pc) = fr in
case match_ex_table P (cname_of h a) pc (ex_table_of P C M) of
None ⇒ find_handler P a h frs
| Some pc_d ⇒ (None, h, (Addr a # drop (size stk - snd pc_d) stk, loc, C, M, fst pc_d)#frs))"
end
Theory JVMExec
section ‹Program Execution in the JVM›
theory JVMExec
imports JVMExecInstr JVMExceptions
begin
abbreviation
instrs_of :: "jvm_prog ⇒ cname ⇒ mname ⇒ instr list" where
"instrs_of P C M == fst(snd(snd(snd(snd(snd(method P C M))))))"
fun exec :: "jvm_prog × jvm_state => jvm_state option" where
"exec (P, xp, h, []) = None"
| "exec (P, None, h, (stk,loc,C,M,pc)#frs) =
(let
i = instrs_of P C M ! pc;
(xcpt', h', frs') = exec_instr i P h stk loc C M pc frs
in Some(case xcpt' of
None ⇒ (None,h',frs')
| Some a ⇒ find_handler P a h ((stk,loc,C,M,pc)#frs)))"
| "exec (P, Some xa, h, frs) = None"
inductive_set
exec_1 :: "jvm_prog ⇒ (jvm_state × jvm_state) set"
and exec_1' :: "jvm_prog ⇒ jvm_state ⇒ jvm_state ⇒ bool"
("_ ⊢/ _ -jvm→⇩1/ _" [61,61,61] 60)
for P :: jvm_prog
where
"P ⊢ σ -jvm→⇩1 σ' ≡ (σ,σ') ∈ exec_1 P"
| exec_1I: "exec (P,σ) = Some σ' ⟹ P ⊢ σ -jvm→⇩1 σ'"
definition exec_all :: "jvm_prog ⇒ jvm_state ⇒ jvm_state ⇒ bool"
("(_ ⊢/ _ -jvm→/ _)" [61,61,61]60) where
exec_all_def1: "P ⊢ σ -jvm→ σ' ⟷ (σ,σ') ∈ (exec_1 P)⇧*"
notation (ASCII)
exec_all ("_ |-/ _ -jvm->/ _" [61,61,61]60)
lemma exec_1_eq:
"exec_1 P = {(σ,σ'). exec (P,σ) = Some σ'}"
by (auto intro: exec_1I elim: exec_1.cases)
lemma exec_1_iff:
"P ⊢ σ -jvm→⇩1 σ' = (exec (P,σ) = Some σ')"
by (simp add: exec_1_eq)
lemma exec_all_def:
"P ⊢ σ -jvm→ σ' = ((σ,σ') ∈ {(σ,σ'). exec (P,σ) = Some σ'}⇧*)"
by (simp add: exec_all_def1 exec_1_eq)
lemma jvm_refl[iff]: "P ⊢ σ -jvm→ σ"
by(simp add: exec_all_def)
lemma jvm_trans[trans]:
"⟦ P ⊢ σ -jvm→ σ'; P ⊢ σ' -jvm→ σ'' ⟧ ⟹ P ⊢ σ -jvm→ σ''"
by(simp add: exec_all_def)
lemma jvm_one_step1[trans]:
"⟦ P ⊢ σ -jvm→⇩1 σ'; P ⊢ σ' -jvm→ σ'' ⟧ ⟹ P ⊢ σ -jvm→ σ''"
by (simp add: exec_all_def1)
lemma jvm_one_step2[trans]:
"⟦ P ⊢ σ -jvm→ σ'; P ⊢ σ' -jvm→⇩1 σ'' ⟧ ⟹ P ⊢ σ -jvm→ σ''"
by (simp add: exec_all_def1)
lemma exec_all_conf:
"⟦ P ⊢ σ -jvm→ σ'; P ⊢ σ -jvm→ σ'' ⟧
⟹ P ⊢ σ' -jvm→ σ'' ∨ P ⊢ σ'' -jvm→ σ'"
by(simp add: exec_all_def single_valued_def single_valued_confluent)
lemma exec_all_finalD: "P ⊢ (x, h, []) -jvm→ σ ⟹ σ = (x, h, [])"
apply(simp only: exec_all_def)
apply(erule converse_rtranclE)
apply simp
apply simp
done
lemma exec_all_deterministic:
"⟦ P ⊢ σ -jvm→ (x,h,[]); P ⊢ σ -jvm→ σ' ⟧ ⟹ P ⊢ σ' -jvm→ (x,h,[])"
apply(drule (1) exec_all_conf)
apply(blast dest!: exec_all_finalD)
done
text ‹
The start configuration of the JVM: in the start heap, we call a
method ‹m› of class ‹C› in program ‹P›. The
‹this› pointer of the frame is set to ‹Null› to simulate
a static method invokation.
›
definition start_state :: "jvm_prog ⇒ cname ⇒ mname ⇒ jvm_state" where
"start_state P C M =
(let (D,Ts,T,mxs,mxl⇩0,b) = method P C M in
(None, start_heap P, [([], Null # replicate mxl⇩0 undefined, C, M, 0)]))"
end
Theory JVMDefensive
section ‹A Defensive JVM›
theory JVMDefensive
imports JVMExec "../Common/Conform"
begin
text ‹
Extend the state space by one element indicating a type error (or
other abnormal termination)›
datatype 'a type_error = TypeError | Normal 'a
fun is_Addr :: "val ⇒ bool" where
"is_Addr (Addr a) ⟷ True"
| "is_Addr v ⟷ False"
fun is_Intg :: "val ⇒ bool" where
"is_Intg (Intg i) ⟷ True"
| "is_Intg v ⟷ False"
fun is_Bool :: "val ⇒ bool" where
"is_Bool (Bool b) ⟷ True"
| "is_Bool v ⟷ False"
definition is_Ref :: "val ⇒ bool" where
"is_Ref v ⟷ v = Null ∨ is_Addr v"
primrec check_instr :: "[instr, jvm_prog, heap, val list, val list,
cname, mname, pc, frame list] ⇒ bool" where
check_instr_Load:
"check_instr (Load n) P h stk loc C M⇩0 pc frs =
(n < length loc)"
| check_instr_Store:
"check_instr (Store n) P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ n < length loc)"
| check_instr_Push:
"check_instr (Push v) P h stk loc C⇩0 M⇩0 pc frs =
(¬is_Addr v)"
| check_instr_New:
"check_instr (New C) P h stk loc C⇩0 M⇩0 pc frs =
is_class P C"
| check_instr_Getfield:
"check_instr (Getfield F C) P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ (∃C' T. P ⊢ C sees F:T in C') ∧
(let (C', T) = field P C F; ref = hd stk in
C' = C ∧ is_Ref ref ∧ (ref ≠ Null ⟶
h (the_Addr ref) ≠ None ∧
(let (D,vs) = the (h (the_Addr ref)) in
P ⊢ D ≼⇧* C ∧ vs (F,C) ≠ None ∧ P,h ⊢ the (vs (F,C)) :≤ T))))"
| check_instr_Putfield:
"check_instr (Putfield F C) P h stk loc C⇩0 M⇩0 pc frs =
(1 < length stk ∧ (∃C' T. P ⊢ C sees F:T in C') ∧
(let (C', T) = field P C F; v = hd stk; ref = hd (tl stk) in
C' = C ∧ is_Ref ref ∧ (ref ≠ Null ⟶
h (the_Addr ref) ≠ None ∧
(let D = fst (the (h (the_Addr ref))) in
P ⊢ D ≼⇧* C ∧ P,h ⊢ v :≤ T))))"
| check_instr_Checkcast:
"check_instr (Checkcast C) P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ is_class P C ∧ is_Ref (hd stk))"
| check_instr_Invoke:
"check_instr (Invoke M n) P h stk loc C⇩0 M⇩0 pc frs =
(n < length stk ∧ is_Ref (stk!n) ∧
(stk!n ≠ Null ⟶
(let a = the_Addr (stk!n);
C = cname_of h a;
Ts = fst (snd (method P C M))
in h a ≠ None ∧ P ⊢ C has M ∧
P,h ⊢ rev (take n stk) [:≤] Ts)))"
| check_instr_Return:
"check_instr Return P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ ((0 < length frs) ⟶
(P ⊢ C⇩0 has M⇩0) ∧
(let v = hd stk;
T = fst (snd (snd (method P C⇩0 M⇩0)))
in P,h ⊢ v :≤ T)))"
| check_instr_Pop:
"check_instr Pop P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk)"
| check_instr_IAdd:
"check_instr IAdd P h stk loc C⇩0 M⇩0 pc frs =
(1 < length stk ∧ is_Intg (hd stk) ∧ is_Intg (hd (tl stk)))"
| check_instr_IfFalse:
"check_instr (IfFalse b) P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ is_Bool (hd stk) ∧ 0 ≤ int pc+b)"
| check_instr_CmpEq:
"check_instr CmpEq P h stk loc C⇩0 M⇩0 pc frs =
(1 < length stk)"
| check_instr_Goto:
"check_instr (Goto b) P h stk loc C⇩0 M⇩0 pc frs =
(0 ≤ int pc+b)"
| check_instr_Throw:
"check_instr Throw P h stk loc C⇩0 M⇩0 pc frs =
(0 < length stk ∧ is_Ref (hd stk))"
definition check :: "jvm_prog ⇒ jvm_state ⇒ bool" where
"check P σ = (let (xcpt, h, frs) = σ in
(case frs of [] ⇒ True | (stk,loc,C,M,pc)#frs' ⇒
P ⊢ C has M ∧
(let (C',Ts,T,mxs,mxl⇩0,ins,xt) = method P C M; i = ins!pc in
pc < size ins ∧ size stk ≤ mxs ∧
check_instr i P h stk loc C M pc frs')))"
definition exec_d :: "jvm_prog ⇒ jvm_state ⇒ jvm_state option type_error" where
"exec_d P σ = (if check P σ then Normal (exec (P, σ)) else TypeError)"
inductive_set
exec_1_d :: "jvm_prog ⇒ (jvm_state type_error × jvm_state type_error) set"
and exec_1_d' :: "jvm_prog ⇒ jvm_state type_error ⇒ jvm_state type_error ⇒ bool"
("_ ⊢ _ -jvmd→⇩1 _" [61,61,61]60)
for P :: jvm_prog
where
"P ⊢ σ -jvmd→⇩1 σ' ≡ (σ,σ') ∈ exec_1_d P"
| exec_1_d_ErrorI: "exec_d P σ = TypeError ⟹ P ⊢ Normal σ -jvmd→⇩1 TypeError"
| exec_1_d_NormalI: "exec_d P σ = Normal (Some σ') ⟹ P ⊢ Normal σ -jvmd→⇩1 Normal σ'"
definition exec_all_d :: "jvm_prog ⇒ jvm_state type_error ⇒ jvm_state type_error ⇒ bool"
("_ ⊢ _ -jvmd→ _" [61,61,61]60) where
exec_all_d_def1: "P ⊢ σ -jvmd→ σ' ⟷ (σ,σ') ∈ (exec_1_d P)⇧*"
notation (ASCII)
"exec_all_d" ("_ |- _ -jvmd-> _" [61,61,61]60)
lemma exec_1_d_eq:
"exec_1_d P = {(s,t). ∃σ. s = Normal σ ∧ t = TypeError ∧ exec_d P σ = TypeError} ∪
{(s,t). ∃σ σ'. s = Normal σ ∧ t = Normal σ' ∧ exec_d P σ = Normal (Some σ')}"
by (auto elim!: exec_1_d.cases intro!: exec_1_d.intros)
declare split_paired_All [simp del]
declare split_paired_Ex [simp del]
lemma if_neq [dest!]:
"(if P then A else B) ≠ B ⟹ P"
by (cases P, auto)
lemma exec_d_no_errorI [intro]:
"check P σ ⟹ exec_d P σ ≠ TypeError"
by (unfold exec_d_def) simp
theorem no_type_error_commutes:
"exec_d P σ ≠ TypeError ⟹ exec_d P σ = Normal (exec (P, σ))"
by (unfold exec_d_def, auto)
lemma defensive_imp_aggressive:
"P ⊢ (Normal σ) -jvmd→ (Normal σ') ⟹ P ⊢ σ -jvm→ σ'"
proof -
have "⋀x y. P ⊢ x -jvmd→ y ⟹ ∀σ σ'. x = Normal σ ⟶ y = Normal σ' ⟶ P ⊢ σ -jvm→ σ'"
apply (unfold exec_all_d_def1)
apply (erule rtrancl_induct)
apply (simp add: exec_all_def)
apply (fold exec_all_d_def1)
apply simp
apply (intro allI impI)
apply (erule exec_1_d.cases, simp)
apply (simp add: exec_all_def exec_d_def split: type_error.splits if_split_asm)
apply (rule rtrancl_trans, assumption)
apply blast
done
moreover
assume "P ⊢ (Normal σ) -jvmd→ (Normal σ')"
ultimately
show "P ⊢ σ -jvm→ σ'" by blast
qed
end
Theory JVMListExample
section ‹Example for generating executable code from JVM semantics \label{sec:JVMListExample}›
theory JVMListExample
imports
"../Common/SystemClasses"
JVMExec
"HOL-Library.Code_Target_Numeral"
begin
definition list_name :: string
where
"list_name == ''list''"
definition test_name :: string
where
"test_name == ''test''"
definition val_name :: string
where
"val_name == ''val''"
definition next_name :: string
where
"next_name == ''next''"
definition append_name :: string
where
"append_name == ''append''"
definition makelist_name :: string
where
"makelist_name == ''makelist''"
definition append_ins :: bytecode
where
"append_ins ==
[Load 0,
Getfield next_name list_name,
Load 0,
Getfield next_name list_name,
Push Null,
CmpEq,
IfFalse 7,
Pop,
Load 0,
Load 1,
Putfield next_name list_name,
Push Unit,
Return,
Load 1,
Invoke append_name 1,
Return]"
definition list_class :: "jvm_method class"
where
"list_class ==
(Object,
[(val_name, Integer), (next_name, Class list_name)],
[(append_name, [Class list_name], Void,
(3, 0, append_ins, [(1, 2, NullPointer, 7, 0)]))])"
definition make_list_ins :: bytecode
where
"make_list_ins ==
[New list_name,
Store 0,
Load 0,
Push (Intg 1),
Putfield val_name list_name,
New list_name,
Store 1,
Load 1,
Push (Intg 2),
Putfield val_name list_name,
New list_name,
Store 2,
Load 2,
Push (Intg 3),
Putfield val_name list_name,
Load 0,
Load 1,
Invoke append_name 1,
Pop,
Load 0,
Load 2,
Invoke append_name 1,
Return]"
definition test_class :: "jvm_method class"
where
"test_class ==
(Object, [],
[(makelist_name, [], Void, (3, 2, make_list_ins, []))])"
definition E :: jvm_prog
where
"E == SystemClasses @ [(list_name, list_class), (test_name, test_class)]"
definition undefined_cname :: cname
where [code del]: "undefined_cname = undefined"
declare undefined_cname_def[symmetric, code_unfold]
code_printing constant undefined_cname ⇀ (SML) "object"
definition undefined_val :: val
where [code del]: "undefined_val = undefined"
declare undefined_val_def[symmetric, code_unfold]
code_printing constant undefined_val ⇀ (SML) "Unit"
lemmas [code_unfold] = SystemClasses_def [unfolded ObjectC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def]
definition "test = exec (E, start_state E test_name makelist_name)"
ML_val ‹
@{code test};
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
@{code exec} (@{code E}, @{code the} it);
val SOME (_, (h, _)) = it;
if snd (@{code the} (h (@{code nat_of_integer} 3))) (@{code val_name}, @{code list_name}) =
SOME (@{code Intg} (@{code int_of_integer} 1)) then () else error "wrong result";
if snd (@{code the} (h (@{code nat_of_integer} 3))) (@{code next_name}, @{code list_name}) =
SOME (@{code Addr} (@{code nat_of_integer} 4)) then () else error "wrong result";
if snd (@{code the} (h (@{code nat_of_integer} 4))) (@{code val_name}, @{code list_name}) =
SOME (@{code Intg} (@{code int_of_integer} 2)) then () else error "wrong result";
if snd (@{code the} (h (@{code nat_of_integer} 4))) (@{code next_name}, @{code list_name}) =
SOME (@{code Addr} (@{code nat_of_integer} 5)) then () else error "wrong result";
if snd (@{code the} (h (@{code nat_of_integer} 5))) (@{code val_name}, @{code list_name}) =
SOME (@{code Intg} (@{code int_of_integer} 3)) then () else error "wrong result";
if snd (@{code the} (h (@{code nat_of_integer} 5))) (@{code next_name}, @{code list_name}) =
SOME @{code Null} then () else error "wrong result";
›
end
Theory Semilat
chapter ‹Bytecode Verifier \label{cha:bv}›
section ‹Semilattices›
theory Semilat
imports Main "HOL-Library.While_Combinator"
begin
type_synonym 'a ord = "'a ⇒ 'a ⇒ bool"
type_synonym 'a binop = "'a ⇒ 'a ⇒ 'a"
type_synonym 'a sl = "'a set × 'a ord × 'a binop"
definition lesub :: "'a ⇒ 'a ord ⇒ 'a ⇒ bool"
where "lesub x r y ⟷ r x y"
definition lesssub :: "'a ⇒ 'a ord ⇒ 'a ⇒ bool"
where "lesssub x r y ⟷ lesub x r y ∧ x ≠ y"
definition plussub :: "'a ⇒ ('a ⇒ 'b ⇒ 'c) ⇒ 'b ⇒ 'c"
where "plussub x f y = f x y"
notation (ASCII)
"lesub" ("(_ /<='__ _)" [50, 1000, 51] 50) and
"lesssub" ("(_ /<'__ _)" [50, 1000, 51] 50) and
"plussub" ("(_ /+'__ _)" [65, 1000, 66] 65)
notation
"lesub" ("(_ /⊑⇘_⇙ _)" [50, 0, 51] 50) and
"lesssub" ("(_ /⊏⇘_⇙ _)" [50, 0, 51] 50) and
"plussub" ("(_ /⊔⇘_⇙ _)" [65, 0, 66] 65)
abbreviation (input)
lesub1 :: "'a ⇒ 'a ord ⇒ 'a ⇒ bool" ("(_ /⊑⇩_ _)" [50, 1000, 51] 50)
where "x ⊑⇩r y == x ⊑⇘r⇙ y"
abbreviation (input)
lesssub1 :: "'a ⇒ 'a ord ⇒ 'a ⇒ bool" ("(_ /⊏⇩_ _)" [50, 1000, 51] 50)
where "x ⊏⇩r y == x ⊏⇘r⇙ y"
abbreviation (input)
plussub1 :: "'a ⇒ ('a ⇒ 'b ⇒ 'c) ⇒ 'b ⇒ 'c" ("(_ /⊔⇩_ _)" [65, 1000, 66] 65)
where "x ⊔⇩f y == x ⊔⇘f⇙ y"
definition ord :: "('a × 'a) set ⇒ 'a ord"
where
"ord r = (λx y. (x,y) ∈ r)"
definition order :: "'a ord ⇒ bool"
where
"order r ⟷ (∀x. x ⊑⇩r x) ∧ (∀x y. x ⊑⇩r y ∧ y ⊑⇩r x ⟶ x=y) ∧ (∀x y z. x ⊑⇩r y ∧ y ⊑⇩r z ⟶ x ⊑⇩r z)"
definition top :: "'a ord ⇒ 'a ⇒ bool"
where
"top r T ⟷ (∀x. x ⊑⇩r T)"
definition acc :: "'a ord ⇒ bool"
where
"acc r ⟷ wf {(y,x). x ⊏⇩r y}"
definition closed :: "'a set ⇒ 'a binop ⇒ bool"
where
"closed A f ⟷ (∀x∈A. ∀y∈A. x ⊔⇩f y ∈ A)"
definition semilat :: "'a sl ⇒ bool"
where
"semilat = (λ(A,r,f). order r ∧ closed A f ∧
(∀x∈A. ∀y∈A. x ⊑⇩r x ⊔⇩f y) ∧
(∀x∈A. ∀y∈A. y ⊑⇩r x ⊔⇩f y) ∧
(∀x∈A. ∀y∈A. ∀z∈A. x ⊑⇩r z ∧ y ⊑⇩r z ⟶ x ⊔⇩f y ⊑⇩r z))"
definition is_ub :: "('a × 'a) set ⇒ 'a ⇒ 'a ⇒ 'a ⇒ bool"
where
"is_ub r x y u ⟷ (x,u)∈r ∧ (y,u)∈r"
definition is_lub :: "('a × 'a) set ⇒ 'a ⇒ 'a ⇒ 'a ⇒ bool"
where
"is_lub r x y u ⟷ is_ub r x y u ∧ (∀z. is_ub r x y z ⟶ (u,z)∈r)"
definition some_lub :: "('a × 'a) set ⇒ 'a ⇒ 'a ⇒ 'a"
where
"some_lub r x y = (SOME z. is_lub r x y z)"
locale Semilat =
fixes A :: "'a set"
fixes r :: "'a ord"
fixes f :: "'a binop"
assumes semilat: "semilat (A, r, f)"
lemma order_refl [simp, intro]: "order r ⟹ x ⊑⇩r x"
by (unfold order_def) (simp (no_asm_simp))
lemma order_antisym: "⟦ order r; x ⊑⇩r y; y ⊑⇩r x ⟧ ⟹ x = y"
by (unfold order_def) (simp (no_asm_simp))
lemma order_trans: "⟦ order r; x ⊑⇩r y; y ⊑⇩r z ⟧ ⟹ x ⊑⇩r z"
by (unfold order_def) blast
lemma order_less_irrefl [intro, simp]: "order r ⟹ ¬ x ⊏⇩r x"
by (unfold order_def lesssub_def) blast
lemma order_less_trans: "⟦ order r; x ⊏⇩r y; y ⊏⇩r z ⟧ ⟹ x ⊏⇩r z"
by (unfold order_def lesssub_def) blast
lemma topD [simp, intro]: "top r T ⟹ x ⊑⇩r T"
by (simp add: top_def)
lemma top_le_conv [simp]: "⟦ order r; top r T ⟧ ⟹ (T ⊑⇩r x) = (x = T)"
by (blast intro: order_antisym)
lemma semilat_Def:
"semilat(A,r,f) ⟷ order r ∧ closed A f ∧
(∀x∈A. ∀y∈A. x ⊑⇩r x ⊔⇩f y) ∧
(∀x∈A. ∀y∈A. y ⊑⇩r x ⊔⇩f y) ∧
(∀x∈A. ∀y∈A. ∀z∈A. x ⊑⇩r z ∧ y ⊑⇩r z ⟶ x ⊔⇩f y ⊑⇩r z)"
by (unfold semilat_def) clarsimp
lemma (in Semilat) orderI [simp, intro]: "order r"
using semilat by (simp add: semilat_Def)
lemma (in Semilat) closedI [simp, intro]: "closed A f"
using semilat by (simp add: semilat_Def)
lemma closedD: "⟦ closed A f; x∈A; y∈A ⟧ ⟹ x ⊔⇩f y ∈ A"
by (unfold closed_def) blast
lemma closed_UNIV [simp]: "closed UNIV f"
by (simp add: closed_def)
lemma (in Semilat) closed_f [simp, intro]: "⟦x ∈ A; y ∈ A⟧ ⟹ x ⊔⇩f y ∈ A"
by (simp add: closedD [OF closedI])
lemma (in Semilat) refl_r [intro, simp]: "x ⊑⇩r x" by simp
lemma (in Semilat) antisym_r [intro?]: "⟦ x ⊑⇩r y; y ⊑⇩r x ⟧ ⟹ x = y"
by (rule order_antisym) auto
lemma (in Semilat) trans_r [trans, intro?]: "⟦x ⊑⇩r y; y ⊑⇩r z⟧ ⟹ x ⊑⇩r z"
by (auto intro: order_trans)
lemma (in Semilat) ub1 [simp, intro?]: "⟦ x ∈ A; y ∈ A ⟧ ⟹ x ⊑⇩r x ⊔⇩f y"
by (insert semilat) (unfold semilat_Def, simp)
lemma (in Semilat) ub2 [simp, intro?]: "⟦ x ∈ A; y ∈ A ⟧ ⟹ y ⊑⇩r x ⊔⇩f y"
by (insert semilat) (unfold semilat_Def, simp)
lemma (in Semilat) lub [simp, intro?]:
"⟦ x ⊑⇩r z; y ⊑⇩r z; x ∈ A; y ∈ A; z ∈ A ⟧ ⟹ x ⊔⇩f y ⊑⇩r z"
by (insert semilat) (unfold semilat_Def, simp)
lemma (in Semilat) plus_le_conv [simp]:
"⟦ x ∈ A; y ∈ A; z ∈ A ⟧ ⟹ (x ⊔⇩f y ⊑⇩r z) = (x ⊑⇩r z ∧ y ⊑⇩r z)"
by (blast intro: ub1 ub2 lub order_trans)
lemma (in Semilat) le_iff_plus_unchanged:
assumes "x ∈ A" and "y ∈ A"
shows "x ⊑⇩r y ⟷ x ⊔⇩f y = y" (is "?P ⟷ ?Q")
proof
assume ?P
with assms show ?Q by (blast intro: antisym_r lub ub2)
next
assume ?Q
then have "y = x ⊔⇘f⇙ y" by simp
moreover from assms have "x ⊑⇘r⇙ x ⊔⇘f⇙ y" by simp
ultimately show ?P by simp
qed
lemma (in Semilat) le_iff_plus_unchanged2:
assumes "x ∈ A" and "y ∈ A"
shows "x ⊑⇩r y ⟷ y ⊔⇩f x = y" (is "?P ⟷ ?Q")
proof
assume ?P
with assms show ?Q by (blast intro: antisym_r lub ub1)
next
assume ?Q
then have "y = y ⊔⇘f⇙ x" by simp
moreover from assms have "x ⊑⇘r⇙ y ⊔⇘f⇙ x" by simp
ultimately show ?P by simp
qed
lemma (in Semilat) plus_assoc [simp]:
assumes a: "a ∈ A" and b: "b ∈ A" and c: "c ∈ A"
shows "a ⊔⇩f (b ⊔⇩f c) = a ⊔⇩f b ⊔⇩f c"
proof -
from a b have ab: "a ⊔⇩f b ∈ A" ..
from this c have abc: "(a ⊔⇩f b) ⊔⇩f c ∈ A" ..
from b c have bc: "b ⊔⇩f c ∈ A" ..
from a this have abc': "a ⊔⇩f (b ⊔⇩f c) ∈ A" ..
show ?thesis
proof
show "a ⊔⇩f (b ⊔⇩f c) ⊑⇩r (a ⊔⇩f b) ⊔⇩f c"
proof -
from a b have "a ⊑⇩r a ⊔⇩f b" ..
also from ab c have "… ⊑⇩r … ⊔⇩f c" ..
finally have "a<": "a ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" .
from a b have "b ⊑⇩r a ⊔⇩f b" ..
also from ab c have "… ⊑⇩r … ⊔⇩f c" ..
finally have "b<": "b ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" .
from ab c have "c<": "c ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" ..
from "b<" "c<" b c abc have "b ⊔⇩f c ⊑⇩r (a ⊔⇩f b) ⊔⇩f c" ..
from "a<" this a bc abc show ?thesis ..
qed
show "(a ⊔⇩f b) ⊔⇩f c ⊑⇩r a ⊔⇩f (b ⊔⇩f c)"
proof -
from b c have "b ⊑⇩r b ⊔⇩f c" ..
also from a bc have "… ⊑⇩r a ⊔⇩f …" ..
finally have "b<": "b ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" .
from b c have "c ⊑⇩r b ⊔⇩f c" ..
also from a bc have "… ⊑⇩r a ⊔⇩f …" ..
finally have "c<": "c ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" .
from a bc have "a<": "a ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" ..
from "a<" "b<" a b abc' have "a ⊔⇩f b ⊑⇩r a ⊔⇩f (b ⊔⇩f c)" ..
from this "c<" ab c abc' show ?thesis ..
qed
qed
qed
lemma (in Semilat) plus_com_lemma:
"⟦a ∈ A; b ∈ A⟧ ⟹ a ⊔⇩f b ⊑⇩r b ⊔⇩f a"
proof -
assume a: "a ∈ A" and b: "b ∈ A"
from b a have "a ⊑⇩r b ⊔⇩f a" ..
moreover from b a have "b ⊑⇩r b ⊔⇩f a" ..
moreover note a b
moreover from b a have "b ⊔⇩f a ∈ A" ..
ultimately show ?thesis ..
qed
lemma (in Semilat) plus_commutative:
"⟦a ∈ A; b ∈ A⟧ ⟹ a ⊔⇩f b = b ⊔⇩f a"
by(blast intro: order_antisym plus_com_lemma)
lemma is_lubD:
"is_lub r x y u ⟹ is_ub r x y u ∧ (∀z. is_ub r x y z ⟶ (u,z) ∈ r)"
by (simp add: is_lub_def)
lemma is_ubI:
"⟦ (x,u) ∈ r; (y,u) ∈ r ⟧ ⟹ is_ub r x y u"
by (simp add: is_ub_def)
lemma is_ubD:
"is_ub r x y u ⟹ (x,u) ∈ r ∧ (y,u) ∈ r"
by (simp add: is_ub_def)
lemma is_lub_bigger1 [iff]:
"is_lub (r^* ) x y y = ((x,y)∈r^* )"
apply (unfold is_lub_def is_ub_def)
apply blast
done
lemma is_lub_bigger2 [iff]:
"is_lub (r^* ) x y x = ((y,x)∈r^* )"
apply (unfold is_lub_def is_ub_def)
apply blast
done
lemma extend_lub:
"⟦ single_valued r; is_lub (r^* ) x y u; (x',x) ∈ r ⟧
⟹ ∃v. is_lub (r^* ) x' y v"
apply (unfold is_lub_def is_ub_def)
apply (case_tac "(y,x) ∈ r^*")
apply (case_tac "(y,x') ∈ r^*")
apply blast
apply (blast elim: converse_rtranclE dest: single_valuedD)
apply (rule exI)
apply (rule conjI)
apply (blast intro: converse_rtrancl_into_rtrancl dest: single_valuedD)
apply (blast intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
elim: converse_rtranclE dest: single_valuedD)
done
lemma single_valued_has_lubs [rule_format]:
"⟦ single_valued r; (x,u) ∈ r^* ⟧ ⟹ (∀y. (y,u) ∈ r^* ⟶
(∃z. is_lub (r^* ) x y z))"
apply (erule converse_rtrancl_induct)
apply clarify
apply (erule converse_rtrancl_induct)
apply blast
apply (blast intro: converse_rtrancl_into_rtrancl)
apply (blast intro: extend_lub)
done
lemma some_lub_conv:
"⟦ acyclic r; is_lub (r^* ) x y u ⟧ ⟹ some_lub (r^* ) x y = u"
apply (simp only: some_lub_def is_lub_def)
apply (rule someI2)
apply (simp only: is_lub_def)
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
lemma is_lub_some_lub:
"⟦ single_valued r; acyclic r; (x,u)∈r^*; (y,u)∈r^* ⟧
⟹ is_lub (r^* ) x y (some_lub (r^* ) x y)"
by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv)
subsection‹An executable lub-finder›
definition exec_lub :: "('a * 'a) set ⇒ ('a ⇒ 'a) ⇒ 'a binop"
where
"exec_lub r f x y = while (λz. (x,z) ∉ r⇧*) f y"
lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)
lemma acyclic_single_valued_finite:
"⟦acyclic r; single_valued r; (x,y) ∈ r⇧*⟧
⟹ finite (r ∩ {a. (x, a) ∈ r⇧*} × {b. (b, y) ∈ r⇧*})"
apply(erule converse_rtrancl_induct)
apply(rule_tac B = "{}" in finite_subset)
apply(simp only:acyclic_def)
apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
apply simp
apply(rename_tac x x')
apply(subgoal_tac "r ∩ {a. (x,a) ∈ r⇧*} × {b. (b,y) ∈ r⇧*} =
insert (x,x') (r ∩ {a. (x', a) ∈ r⇧*} × {b. (b, y) ∈ r⇧*})")
apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
elim:converse_rtranclE dest:single_valuedD)
done
lemma exec_lub_conv:
"⟦ acyclic r; ∀x y. (x,y) ∈ r ⟶ f x = y; is_lub (r⇧*) x y u ⟧ ⟹
exec_lub r f x y = u"
apply(unfold exec_lub_def)
apply(rule_tac P = "λz. (y,z) ∈ r⇧* ∧ (z,u) ∈ r⇧*" and
r = "(r ∩ {(a,b). (y,a) ∈ r⇧* ∧ (b,u) ∈ r⇧*})^-1" in while_rule)
apply(blast dest: is_lubD is_ubD)
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
apply(rename_tac s)
apply(subgoal_tac "is_ub (r⇧*) x y s")
prefer 2 apply(simp add:is_ub_def)
apply(subgoal_tac "(u, s) ∈ r⇧*")
prefer 2 apply(blast dest:is_lubD)
apply(erule converse_rtranclE)
apply blast
apply(simp only:acyclic_def)
apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
apply(rule finite_acyclic_wf)
apply simp
apply(erule acyclic_single_valued_finite)
apply(blast intro:single_valuedI)
apply(simp add:is_lub_def is_ub_def)
apply simp
apply(erule acyclic_subset)
apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
lemma is_lub_exec_lub:
"⟦ single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; ∀x y. (x,y) ∈ r ⟶ f x = y ⟧
⟹ is_lub (r^* ) x y (exec_lub r f x y)"
by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv)
end
Theory Err
section ‹The Error Type›
theory Err
imports Semilat
begin
datatype 'a err = Err | OK 'a
type_synonym 'a ebinop = "'a ⇒ 'a ⇒ 'a err"
type_synonym 'a esl = "'a set × 'a ord × 'a ebinop"
primrec ok_val :: "'a err ⇒ 'a"
where
"ok_val (OK x) = x"
definition lift :: "('a ⇒ 'b err) ⇒ ('a err ⇒ 'b err)"
where
"lift f e = (case e of Err ⇒ Err | OK x ⇒ f x)"
definition lift2 :: "('a ⇒ 'b ⇒ 'c err) ⇒ 'a err ⇒ 'b err ⇒ 'c err"
where
"lift2 f e⇩1 e⇩2 =
(case e⇩1 of Err ⇒ Err | OK x ⇒ (case e⇩2 of Err ⇒ Err | OK y ⇒ f x y))"
definition le :: "'a ord ⇒ 'a err ord"
where
"le r e⇩1 e⇩2 =
(case e⇩2 of Err ⇒ True | OK y ⇒ (case e⇩1 of Err ⇒ False | OK x ⇒ x ⊑⇩r y))"
definition sup :: "('a ⇒ 'b ⇒ 'c) ⇒ ('a err ⇒ 'b err ⇒ 'c err)"
where
"sup f = lift2 (λx y. OK (x ⊔⇩f y))"
definition err :: "'a set ⇒ 'a err set"
where
"err A = insert Err {OK x|x. x∈A}"
definition esl :: "'a sl ⇒ 'a esl"
where
"esl = (λ(A,r,f). (A, r, λx y. OK(f x y)))"
definition sl :: "'a esl ⇒ 'a err sl"
where
"sl = (λ(A,r,f). (err A, le r, lift2 f))"
abbreviation
err_semilat :: "'a esl ⇒ bool" where
"err_semilat L == semilat(sl L)"
primrec strict :: "('a ⇒ 'b err) ⇒ ('a err ⇒ 'b err)"
where
"strict f Err = Err"
| "strict f (OK x) = f x"
lemma err_def':
"err A = insert Err {x. ∃y∈A. x = OK y}"
proof -
have eq: "err A = insert Err {x. ∃y∈A. x = OK y}"
by (unfold err_def) blast
show "err A = insert Err {x. ∃y∈A. x = OK y}" by (simp add: eq)
qed
lemma strict_Some [simp]:
"(strict f x = OK y) = (∃z. x = OK z ∧ f z = OK y)"
by (cases x, auto)
lemma not_Err_eq: "(x ≠ Err) = (∃a. x = OK a)"
by (cases x) auto
lemma not_OK_eq: "(∀y. x ≠ OK y) = (x = Err)"
by (cases x) auto
lemma unfold_lesub_err: "e1 ⊑⇘le r⇙ e2 = le r e1 e2"
by (simp add: lesub_def)
lemma le_err_refl: "∀x. x ⊑⇩r x ⟹ e ⊑⇘le r⇙ e"
apply (unfold lesub_def le_def)
apply (simp split: err.split)
done
lemma le_err_trans [rule_format]:
"order r ⟹ e1 ⊑⇘le r⇙ e2 ⟶ e2 ⊑⇘le r⇙ e3 ⟶ e1 ⊑⇘le r⇙ e3"
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_trans)
done
lemma le_err_antisym [rule_format]:
"order r ⟹ e1 ⊑⇘le r⇙ e2 ⟶ e2 ⊑⇘le r⇙ e1 ⟶ e1=e2"
apply (unfold unfold_lesub_err le_def)
apply (simp split: err.split)
apply (blast intro: order_antisym)
done
lemma OK_le_err_OK: "(OK x ⊑⇘le r⇙ OK y) = (x ⊑⇩r y)"
by (simp add: unfold_lesub_err le_def)
lemma order_le_err [iff]: "order(le r) = order r"
apply (rule iffI)
apply (subst order_def)
apply (blast dest: order_antisym OK_le_err_OK [THEN iffD2]
intro: order_trans OK_le_err_OK [THEN iffD1])
apply (subst order_def)
apply (blast intro: le_err_refl le_err_trans le_err_antisym
dest: order_refl)
done
lemma le_Err [iff]: "e ⊑⇘le r⇙ Err"
by (simp add: unfold_lesub_err le_def)
lemma Err_le_conv [iff]: "Err ⊑⇘le r⇙ e = (e = Err)"
by (simp add: unfold_lesub_err le_def split: err.split)
lemma le_OK_conv [iff]: "e ⊑⇘le r⇙ OK x = (∃y. e = OK y ∧ y ⊑⇩r x)"
by (simp add: unfold_lesub_err le_def split: err.split)
lemma OK_le_conv: "OK x ⊑⇘le r⇙ e = (e = Err ∨ (∃y. e = OK y ∧ x ⊑⇩r y))"
by (simp add: unfold_lesub_err le_def split: err.split)
lemma top_Err [iff]: "top (le r) Err"
by (simp add: top_def)
lemma OK_less_conv [rule_format, iff]:
"OK x ⊏⇘le r⇙ e = (e=Err ∨ (∃y. e = OK y ∧ x ⊏⇩r y))"
by (simp add: lesssub_def lesub_def le_def split: err.split)
lemma not_Err_less [rule_format, iff]: "¬(Err ⊏⇘le r⇙ x)"
by (simp add: lesssub_def lesub_def le_def split: err.split)
lemma semilat_errI [intro]: assumes "Semilat A r f"
shows "semilat(err A, le r, lift2(λx y. OK(f x y)))"
proof -
interpret Semilat A r f by fact
show ?thesis
apply(insert semilat)
apply (simp only: semilat_Def closed_def plussub_def lesub_def
lift2_def le_def)
apply (simp add: err_def' split: err.split)
done
qed
lemma err_semilat_eslI_aux:
assumes "Semilat A r f" shows "err_semilat(esl(A,r,f))"
proof -
interpret Semilat A r f by fact
show ?thesis
apply (unfold sl_def esl_def)
apply (simp add: semilat_errI [OF ‹Semilat A r f›])
done
qed
lemma err_semilat_eslI [intro, simp]:
"semilat L ⟹ err_semilat (esl L)"
apply (cases L) apply simp
apply (drule Semilat.intro)
apply (simp add: err_semilat_eslI_aux split_tupled_all)
done
lemma acc_err [simp, intro!]: "acc r ⟹ acc(le r)"
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: err.split)
apply clarify
apply (case_tac "Err : Q")
apply blast
apply (erule_tac x = "{a . OK a : Q}" in allE)
apply (case_tac "x")
apply fast
apply blast
done
lemma Err_in_err [iff]: "Err : err A"
by (simp add: err_def')
lemma Ok_in_err [iff]: "(OK x ∈ err A) = (x∈A)"
by (auto simp add: err_def')
subsection ‹lift›
lemma lift_in_errI:
"⟦ e ∈ err S; ∀x∈S. e = OK x ⟶ f x ∈ err S ⟧ ⟹ lift f e ∈ err S"
apply (unfold lift_def)
apply (simp split: err.split)
apply blast
done
lemma Err_lift2 [simp]: "Err ⊔⇘lift2 f⇙ x = Err"
by (simp add: lift2_def plussub_def)
lemma lift2_Err [simp]: "x ⊔⇘lift2 f⇙ Err = Err"
by (simp add: lift2_def plussub_def split: err.split)
lemma OK_lift2_OK [simp]: "OK x ⊔⇘lift2 f⇙ OK y = x ⊔⇩f y"
by (simp add: lift2_def plussub_def split: err.split)
subsection ‹sup›
lemma Err_sup_Err [simp]: "Err ⊔⇘sup f⇙ x = Err"
by (simp add: plussub_def sup_def lift2_def)
lemma Err_sup_Err2 [simp]: "x ⊔⇘sup f⇙ Err = Err"
by (simp add: plussub_def sup_def lift2_def split: err.split)
lemma Err_sup_OK [simp]: "OK x ⊔⇘sup f⇙ OK y = OK (x ⊔⇩f y)"
by (simp add: plussub_def sup_def lift2_def)
lemma Err_sup_eq_OK_conv [iff]:
"(sup f ex ey = OK z) = (∃x y. ex = OK x ∧ ey = OK y ∧ f x y = z)"
apply (unfold sup_def lift2_def plussub_def)
apply (rule iffI)
apply (simp split: err.split_asm)
apply clarify
apply simp
done
lemma Err_sup_eq_Err [iff]: "(sup f ex ey = Err) = (ex=Err ∨ ey=Err)"
apply (unfold sup_def lift2_def plussub_def)
apply (simp split: err.split)
done
subsection ‹semilat (err A) (le r) f›
lemma semilat_le_err_Err_plus [simp]:
"⟦ x∈ err A; semilat(err A, le r, f) ⟧ ⟹ Err ⊔⇩f x = Err"
by (blast intro: Semilat.le_iff_plus_unchanged [THEN iffD1, OF Semilat.intro]
Semilat.le_iff_plus_unchanged2 [THEN iffD1, OF Semilat.intro])
lemma semilat_le_err_plus_Err [simp]:
"⟦ x∈ err A; semilat(err A, le r, f) ⟧ ⟹ x ⊔⇩f Err = Err"
by (blast intro: Semilat.le_iff_plus_unchanged [THEN iffD1, OF Semilat.intro]
Semilat.le_iff_plus_unchanged2 [THEN iffD1, OF Semilat.intro])
lemma semilat_le_err_OK1:
"⟦ x∈A; y∈A; semilat(err A, le r, f); OK x ⊔⇩f OK y = OK z ⟧
⟹ x ⊑⇩r z"
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub1 [OF Semilat.intro])
done
lemma semilat_le_err_OK2:
"⟦ x∈A; y∈A; semilat(err A, le r, f); OK x ⊔⇩f OK y = OK z ⟧
⟹ y ⊑⇩r z"
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst)
apply (simp add: Semilat.ub2 [OF Semilat.intro])
done
lemma eq_order_le:
"⟦ x=y; order r ⟧ ⟹ x ⊑⇩r y"
apply (unfold order_def)
apply blast
done
lemma OK_plus_OK_eq_Err_conv [simp]:
assumes "x∈A" "y∈A" "semilat(err A, le r, fe)"
shows "(OK x ⊔⇘fe⇙ OK y = Err) = (¬(∃z∈A. x ⊑⇩r z ∧ y ⊑⇩r z))"
proof -
have plus_le_conv3: "⋀A x y z f r.
⟦ semilat (A,r,f); x ⊔⇩f y ⊑⇩r z; x∈A; y∈A; z∈A ⟧
⟹ x ⊑⇩r z ∧ y ⊑⇩r z"
by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
from assms show ?thesis
apply (rule_tac iffI)
apply clarify
apply (drule OK_le_err_OK [THEN iffD2])
apply (drule OK_le_err_OK [THEN iffD2])
apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
apply assumption
apply assumption
apply simp
apply simp
apply simp
apply simp
apply (case_tac "OK x ⊔⇘fe⇙ OK y")
apply assumption
apply (rename_tac z)
apply (subgoal_tac "OK z∈ err A")
apply (drule eq_order_le)
apply (erule Semilat.orderI [OF Semilat.intro])
apply (blast dest: plus_le_conv3)
apply (erule subst)
apply (blast intro: Semilat.closedI [OF Semilat.intro] closedD)
done
qed
subsection ‹semilat (err(Union AS))›
lemma all_bex_swap_lemma [iff]:
"(∀x. (∃y∈A. x = f y) ⟶ P x) = (∀y∈A. P(f y))"
by blast
lemma closed_err_Union_lift2I:
"⟦ ∀A∈AS. closed (err A) (lift2 f); AS ≠ {};
∀A∈AS.∀B∈AS. A≠B ⟶ (∀a∈A.∀b∈B. a ⊔⇩f b = Err) ⟧
⟹ closed (err(Union AS)) (lift2 f)"
apply (unfold closed_def err_def')
apply simp
apply clarify
apply simp
apply fast
done
text ‹
If @{term "AS = {}"} the thm collapses to
@{prop "order r ∧ closed {Err} f ∧ Err ⊔⇩f Err = Err"}
which may not hold
›
lemma err_semilat_UnionI:
"⟦ ∀A∈AS. err_semilat(A, r, f); AS ≠ {};
∀A∈AS.∀B∈AS. A≠B ⟶ (∀a∈A.∀b∈B. ¬a ⊑⇩r b ∧ a ⊔⇩f b = Err) ⟧
⟹ err_semilat(Union AS, r, f)"
apply (unfold semilat_def sl_def)
apply (simp add: closed_err_Union_lift2I)
apply (rule conjI)
apply blast
apply (simp add: err_def')
apply (rule conjI)
apply clarify
apply (rename_tac A a u B b)
apply (case_tac "A = B")
apply simp
apply simp
apply (rule conjI)
apply clarify
apply (rename_tac A a u B b)
apply (case_tac "A = B")
apply simp
apply simp
apply clarify
apply (rename_tac A ya yb B yd z C c a b)
apply (case_tac "A = B")
apply (case_tac "A = C")
apply simp
apply simp
apply (case_tac "B = C")
apply simp
apply simp
done
end
Theory Opt
section ‹More about Options›
theory Opt imports Err begin
definition le :: "'a ord ⇒ 'a option ord"
where
"le r o⇩1 o⇩2 =
(case o⇩2 of None ⇒ o⇩1=None | Some y ⇒ (case o⇩1 of None ⇒ True | Some x ⇒ x ⊑⇩r y))"
definition opt :: "'a set ⇒ 'a option set"
where
"opt A = insert None {Some y |y. y ∈ A}"
definition sup :: "'a ebinop ⇒ 'a option ebinop"
where
"sup f o⇩1 o⇩2 =
(case o⇩1 of None ⇒ OK o⇩2
| Some x ⇒ (case o⇩2 of None ⇒ OK o⇩1
| Some y ⇒ (case f x y of Err ⇒ Err | OK z ⇒ OK (Some z))))"
definition esl :: "'a esl ⇒ 'a option esl"
where
"esl = (λ(A,r,f). (opt A, le r, sup f))"
lemma unfold_le_opt:
"o⇩1 ⊑⇘le r⇙ o⇩2 =
(case o⇩2 of None ⇒ o⇩1=None |
Some y ⇒ (case o⇩1 of None ⇒ True | Some x ⇒ x ⊑⇩r y))"
apply (unfold lesub_def le_def)
apply (rule refl)
done
lemma le_opt_refl: "order r ⟹ x ⊑⇘le r⇙ x"
by (simp add: unfold_le_opt split: option.split)
lemma le_opt_trans [rule_format]:
"order r ⟹ x ⊑⇘le r⇙ y ⟶ y ⊑⇘le r⇙ z ⟶ x ⊑⇘le r⇙ z"
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_trans)
done
lemma le_opt_antisym [rule_format]:
"order r ⟹ x ⊑⇘le r⇙ y ⟶ y ⊑⇘le r⇙ x ⟶ x=y"
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_antisym)
done
lemma order_le_opt [intro!,simp]: "order r ⟹ order(le r)"
apply (subst order_def)
apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
done
lemma None_bot [iff]: "None ⊑⇘le r⇙ ox"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
lemma Some_le [iff]: "(Some x ⊑⇘le r⇙ z) = (∃y. z = Some y ∧ x ⊑⇩r y)"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
lemma le_None [iff]: "(x ⊑⇘le r⇙ None) = (x = None)"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
lemma OK_None_bot [iff]: "OK None ⊑⇘Err.le (le r)⇙ x"
by (simp add: lesub_def Err.le_def le_def split: option.split err.split)
lemma sup_None1 [iff]: "x ⊔⇘sup f⇙ None = OK x"
by (simp add: plussub_def sup_def split: option.split)
lemma sup_None2 [iff]: "None ⊔⇘sup f⇙ x = OK x"
by (simp add: plussub_def sup_def split: option.split)
lemma None_in_opt [iff]: "None ∈ opt A"
by (simp add: opt_def)
lemma Some_in_opt [iff]: "(Some x ∈ opt A) = (x ∈ A)"
by (unfold opt_def) auto
lemma semilat_opt [intro, simp]:
"err_semilat L ⟹ err_semilat (Opt.esl L)"
proof -
assume s: "err_semilat L"
obtain A r f where [simp]: "L = (A,r,f)" by (cases L)
let ?A0 = "err A" and ?r0 = "Err.le r" and ?f0 = "lift2 f"
from s obtain
ord: "order ?r0" and
clo: "closed ?A0 ?f0" and
ub1: "∀x∈?A0. ∀y∈?A0. x ⊑⇘?r0⇙ x ⊔⇘?f0⇙ y" and
ub2: "∀x∈?A0. ∀y∈?A0. y ⊑⇘?r0⇙ x ⊔⇘?f0⇙ y" and
lub: "∀x∈?A0. ∀y∈?A0. ∀z∈?A0. x ⊑⇘?r0⇙ z ∧ y ⊑⇘?r0⇙ z ⟶ x ⊔⇘?f0⇙ y ⊑⇘?r0⇙ z"
by (unfold semilat_def sl_def) simp
let ?A = "err (opt A)" and ?r = "Err.le (Opt.le r)" and ?f = "lift2 (Opt.sup f)"
from ord have "order ?r" by simp
moreover
have "closed ?A ?f"
proof (unfold closed_def, intro strip)
fix x y assume x: "x ∈ ?A" and y: "y ∈ ?A"
{ fix a b assume ab: "x = OK a" "y = OK b"
with x have a: "⋀c. a = Some c ⟹ c ∈ A" by (clarsimp simp add: opt_def)
from ab y have b: "⋀d. b = Some d ⟹ d ∈ A" by (clarsimp simp add: opt_def)
{ fix c d assume "a = Some c" "b = Some d"
with ab x y have "c ∈ A & d ∈ A" by (simp add: err_def opt_def Bex_def)
with clo have "f c d ∈ err A"
by (simp add: closed_def plussub_def err_def' lift2_def)
moreover fix z assume "f c d = OK z"
ultimately have "z ∈ A" by simp
} note f_closed = this
have "sup f a b ∈ ?A"
proof (cases a)
case None thus ?thesis
by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
next
case Some thus ?thesis
by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
qed
}
thus "x ⊔⇘?f⇙ y ∈ ?A" by (simp add: plussub_def lift2_def split: err.split)
qed
moreover
{ fix a b c assume "a ∈ opt A" and "b ∈ opt A" and "a ⊔⇘sup f⇙ b = OK c"
moreover from ord have "order r" by simp
moreover
{ fix x y z assume "x ∈ A" and "y ∈ A"
hence "OK x ∈ err A ∧ OK y ∈ err A" by simp
with ub1 ub2
have "(OK x) ⊑⇘Err.le r⇙ (OK x) ⊔⇘lift2 f⇙ (OK y) ∧
(OK y) ⊑⇘Err.le r⇙ (OK x) ⊔⇘lift2 f⇙ (OK y)"
by blast
moreover assume "x ⊔⇩f y = OK z"
ultimately have "x ⊑⇩r z ∧ y ⊑⇩r z"
by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
}
ultimately have "a ⊑⇘le r⇙ c ∧ b ⊑⇘le r⇙ c"
by (auto simp add: sup_def le_def lesub_def plussub_def
dest: order_refl split: option.splits err.splits)
}
hence "(∀x∈?A. ∀y∈?A. x ⊑⇘?r⇙ x ⊔⇘?f⇙ y) ∧ (∀x∈?A. ∀y∈?A. y ⊑⇘?r⇙ x ⊔⇘?f⇙ y)"
by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)
moreover
have "∀x∈?A. ∀y∈?A. ∀z∈?A. x ⊑⇘?r⇙ z ∧ y ⊑⇘?r⇙ z ⟶ x ⊔⇘?f⇙ y ⊑⇘?r⇙ z"
proof (intro strip, elim conjE)
fix x y z
assume xyz: "x ∈ ?A" "y ∈ ?A" "z ∈ ?A"
assume xz: "x ⊑⇘?r⇙ z" and yz: "y ⊑⇘?r⇙ z"
{ fix a b c assume ok: "x = OK a" "y = OK b" "z = OK c"
{ fix d e g assume some: "a = Some d" "b = Some e" "c = Some g"
with ok xyz obtain "OK d:err A" "OK e:err A" "OK g:err A" by simp
with lub
have "⟦ OK d ⊑⇘Err.le r⇙ OK g; OK e ⊑⇘Err.le r⇙ OK g ⟧ ⟹ OK d ⊔⇘lift2 f⇙ OK e ⊑⇘Err.le r⇙ OK g"
by blast
hence "⟦ d ⊑⇩r g; e ⊑⇩r g ⟧ ⟹ ∃y. d ⊔⇩f e = OK y ∧ y ⊑⇩r g" by simp
with ok some xyz xz yz have "x ⊔⇘?f⇙ y ⊑⇘?r⇙ z"
by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
} note this [intro!]
from ok xyz xz yz have "x ⊔⇘?f⇙ y ⊑⇘?r⇙ z"
by - (cases a, simp, cases b, simp, cases c, simp, blast)
}
with xyz xz yz show "x ⊔⇘?f⇙ y ⊑⇘?r⇙ z"
by - (cases x, simp, cases y, simp, cases z, simp+)
qed
ultimately show "err_semilat (Opt.esl L)"
by (unfold semilat_def esl_def sl_def) simp
qed
lemma top_le_opt_Some [iff]: "top (le r) (Some T) = top r T"
apply (unfold top_def)
apply (rule iffI)
apply blast
apply (rule allI)
apply (case_tac "x")
apply simp+
done
lemma Top_le_conv: "⟦ order r; top r T ⟧ ⟹ (T ⊑⇩r x) = (x = T)"
apply (unfold top_def)
apply (blast intro: order_antisym)
done
lemma acc_le_optI [intro!]: "acc r ⟹ acc(le r)"
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: option.split)
apply clarify
apply (case_tac "∃a. Some a ∈ Q")
apply (erule_tac x = "{a . Some a ∈ Q}" in allE)
apply blast
apply (case_tac "x")
apply blast
apply blast
done
lemma map_option_in_optionI:
"⟦ ox ∈ opt S; ∀x∈S. ox = Some x ⟶ f x ∈ S ⟧
⟹ map_option f ox ∈ opt S"
apply (unfold map_option_case)
apply (simp split: option.split)
apply blast
done
end
Theory Product
section ‹Products as Semilattices›
theory Product
imports Err
begin
definition le :: "'a ord ⇒ 'b ord ⇒ ('a × 'b) ord"
where
"le r⇩A r⇩B = (λ(a⇩1,b⇩1) (a⇩2,b⇩2). a⇩1 ⊑⇘r⇩A⇙ a⇩2 ∧ b⇩1 ⊑⇘r⇩B⇙ b⇩2)"
definition sup :: "'a ebinop ⇒ 'b ebinop ⇒ ('a × 'b) ebinop"
where
"sup f g = (λ(a⇩1,b⇩1)(a⇩2,b⇩2). Err.sup Pair (a⇩1 ⊔⇩f a⇩2) (b⇩1 ⊔⇩g b⇩2))"
definition esl :: "'a esl ⇒ 'b esl ⇒ ('a × 'b ) esl"
where
"esl = (λ(A,r⇩A,f⇩A) (B,r⇩B,f⇩B). (A × B, le r⇩A r⇩B, sup f⇩A f⇩B))"
abbreviation
lesubprod :: "'a × 'b ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('b ⇒ 'b ⇒ bool) ⇒ 'a × 'b ⇒ bool"
("(_ /⊑'(_,_') _)" [50, 0, 0, 51] 50) where
"p ⊑(rA,rB) q == p ⊑⇘Product.le rA rB⇙ q"
notation
lesubprod ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
lemma unfold_lesub_prod: "x ⊑(r⇩A,r⇩B) y = le r⇩A r⇩B x y"
by (simp add: lesub_def)
lemma le_prod_Pair_conv [iff]: "((a⇩1,b⇩1) ⊑(r⇩A,r⇩B) (a⇩2,b⇩2)) = (a⇩1 ⊑⇘r⇩A⇙ a⇩2 & b⇩1 ⊑⇘r⇩B⇙ b⇩2)"
by (simp add: lesub_def le_def)
lemma less_prod_Pair_conv:
"((a⇩1,b⇩1) ⊏⇘Product.le r⇩A r⇩B⇙ (a⇩2,b⇩2)) =
(a⇩1 ⊏⇘r⇩A⇙ a⇩2 & b⇩1 ⊑⇘r⇩B⇙ b⇩2 | a⇩1 ⊑⇘r⇩A⇙ a⇩2 & b⇩1 ⊏⇘r⇩B⇙ b⇩2)"
apply (unfold lesssub_def)
apply simp
apply blast
done
lemma order_le_prod [iff]: "order(Product.le r⇩A r⇩B) = (order r⇩A & order r⇩B)"
apply (unfold order_def)
apply simp
apply safe
apply blast+
done
lemma acc_le_prodI [intro!]:
"⟦ acc r⇩A; acc r⇩B ⟧ ⟹ acc(Product.le r⇩A r⇩B)"
apply (unfold acc_def)
apply (rule wf_subset)
apply (erule wf_lex_prod)
apply assumption
apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
done
lemma closed_lift2_sup:
"⟦ closed (err A) (lift2 f); closed (err B) (lift2 g) ⟧ ⟹
closed (err(A×B)) (lift2(sup f g))"
apply (unfold closed_def plussub_def lift2_def err_def' sup_def)
apply (simp split: err.split)
apply blast
done
lemma unfold_plussub_lift2: "e⇩1 ⊔⇘lift2 f⇙ e⇩2 = lift2 f e⇩1 e⇩2"
by (simp add: plussub_def)
lemma plus_eq_Err_conv [simp]:
assumes "x∈A" "y∈A" "semilat(err A, Err.le r, lift2 f)"
shows "(x ⊔⇩f y = Err) = (¬(∃z∈A. x ⊑⇩r z ∧ y ⊑⇩r z))"
proof -
have plus_le_conv2:
"⋀r f z. ⟦ z ∈ err A; semilat (err A, r, f); OK x ∈ err A; OK y ∈ err A;
OK x ⊔⇩f OK y ⊑⇩r z⟧ ⟹ OK x ⊑⇩r z ∧ OK y ⊑⇩r z"
by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1])
from assms show ?thesis
apply (rule_tac iffI)
apply clarify
apply (drule OK_le_err_OK [THEN iffD2])
apply (drule OK_le_err_OK [THEN iffD2])
apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
apply assumption
apply assumption
apply simp
apply simp
apply simp
apply simp
apply (case_tac "x ⊔⇩f y")
apply assumption
apply (rename_tac "z")
apply (subgoal_tac "OK z: err A")
apply (frule plus_le_conv2)
apply assumption
apply simp
apply blast
apply simp
apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
apply blast
apply (erule subst)
apply (unfold semilat_def err_def' closed_def)
apply simp
done
qed
lemma err_semilat_Product_esl:
"⋀L⇩1 L⇩2. ⟦ err_semilat L⇩1; err_semilat L⇩2 ⟧ ⟹ err_semilat(Product.esl L⇩1 L⇩2)"
apply (unfold esl_def Err.sl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (simp (no_asm) only: semilat_Def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
simp add: lift2_def split: err.split)
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
done
end
Theory Listn
section ‹Fixed Length Lists›
theory Listn
imports Err
begin
definition list :: "nat ⇒ 'a set ⇒ 'a list set"
where
"list n A = {xs. size xs = n ∧ set xs ⊆ A}"
definition le :: "'a ord ⇒ ('a list)ord"
where
"le r = list_all2 (λx y. x ⊑⇩r y)"
abbreviation
lesublist :: "'a list ⇒ 'a ord ⇒ 'a list ⇒ bool" ("(_ /[⊑⇘_⇙] _)" [50, 0, 51] 50) where
"x [⊑⇘r⇙] y == x <=_(Listn.le r) y"
abbreviation
lesssublist :: "'a list ⇒ 'a ord ⇒ 'a list ⇒ bool" ("(_ /[⊏⇘_⇙] _)" [50, 0, 51] 50) where
"x [⊏⇘r⇙] y == x <_(Listn.le r) y"
notation (ASCII)
lesublist ("(_ /[<=_] _)" [50, 0, 51] 50) and
lesssublist ("(_ /[<_] _)" [50, 0, 51] 50)
abbreviation (input)
lesublist2 :: "'a list ⇒ 'a ord ⇒ 'a list ⇒ bool" ("(_ /[⊑⇩_] _)" [50, 0, 51] 50) where
"x [⊑⇩r] y == x [⊑⇘r⇙] y"
abbreviation (input)
lesssublist2 :: "'a list ⇒ 'a ord ⇒ 'a list ⇒ bool" ("(_ /[⊏⇩_] _)" [50, 0, 51] 50) where
"x [⊏⇩r] y == x [⊏⇘r⇙] y"
abbreviation
plussublist :: "'a list ⇒ ('a ⇒ 'b ⇒ 'c) ⇒ 'b list ⇒ 'c list"
("(_ /[⊔⇘_⇙] _)" [65, 0, 66] 65) where
"x [⊔⇘f⇙] y == x ⊔⇘map2 f⇙ y"
notation (ASCII)
plussublist ("(_ /[+_] _)" [65, 0, 66] 65)
abbreviation (input)
plussublist2 :: "'a list ⇒ ('a ⇒ 'b ⇒ 'c) ⇒ 'b list ⇒ 'c list"
("(_ /[⊔⇩_] _)" [65, 0, 66] 65) where
"x [⊔⇩f] y == x [⊔⇘f⇙] y"
primrec coalesce :: "'a err list ⇒ 'a list err"
where
"coalesce [] = OK[]"
| "coalesce (ex#exs) = Err.sup (#) ex (coalesce exs)"
definition sl :: "nat ⇒ 'a sl ⇒ 'a list sl"
where
"sl n = (λ(A,r,f). (list n A, le r, map2 f))"
definition sup :: "('a ⇒ 'b ⇒ 'c err) ⇒ 'a list ⇒ 'b list ⇒ 'c list err"
where
"sup f = (λxs ys. if size xs = size ys then coalesce(xs [⊔⇘f⇙] ys) else Err)"
definition upto_esl :: "nat ⇒ 'a esl ⇒ 'a list esl"
where
"upto_esl m = (λ(A,r,f). (Union{list n A |n. n ≤ m}, le r, sup f))"
lemmas [simp] = set_update_subsetI
lemma unfold_lesub_list: "xs [⊑⇘r⇙] ys = Listn.le r xs ys"
by (simp add: lesub_def)
lemma Nil_le_conv [iff]: "([] [⊑⇘r⇙] ys) = (ys = [])"
apply (unfold lesub_def Listn.le_def)
apply simp
done
lemma Cons_notle_Nil [iff]: "¬ x#xs [⊑⇘r⇙] []"
apply (unfold lesub_def Listn.le_def)
apply simp
done
lemma Cons_le_Cons [iff]: "x#xs [⊑⇘r⇙] y#ys = (x ⊑⇩r y ∧ xs [⊑⇘r⇙] ys)"
by (simp add: lesub_def Listn.le_def)
lemma Cons_less_Conss [simp]:
"order r ⟹ x#xs [⊏⇩r] y#ys = (x ⊏⇩r y ∧ xs [⊑⇘r⇙] ys ∨ x = y ∧ xs [⊏⇩r] ys)"
apply (unfold lesssub_def)
apply blast
done
lemma list_update_le_cong:
"⟦ i<size xs; xs [⊑⇘r⇙] ys; x ⊑⇩r y ⟧ ⟹ xs[i:=x] [⊑⇘r⇙] ys[i:=y]"
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (simp add: list_all2_update_cong)
done
lemma le_listD: "⟦ xs [⊑⇘r⇙] ys; p < size xs ⟧ ⟹ xs!p ⊑⇩r ys!p"
by (simp add: Listn.le_def lesub_def list_all2_nthD)
lemma le_list_refl: "∀x. x ⊑⇩r x ⟹ xs [⊑⇘r⇙] xs"
apply (simp add: unfold_lesub_list lesub_def Listn.le_def list_all2_refl)
done
lemma le_list_trans: "⟦ order r; xs [⊑⇘r⇙] ys; ys [⊑⇘r⇙] zs ⟧ ⟹ xs [⊑⇘r⇙] zs"
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_trans)
apply (erule order_trans)
apply assumption+
done
lemma le_list_antisym: "⟦ order r; xs [⊑⇘r⇙] ys; ys [⊑⇘r⇙] xs ⟧ ⟹ xs = ys"
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (rule list_all2_antisym)
apply (rule order_antisym)
apply assumption+
done
lemma order_listI [simp, intro!]: "order r ⟹ order(Listn.le r)"
apply (subst order_def)
apply (blast intro: le_list_refl le_list_trans le_list_antisym
dest: order_refl)
done
lemma lesub_list_impl_same_size [simp]: "xs [⊑⇘r⇙] ys ⟹ size ys = size xs"
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_lengthD)
done
lemma lesssub_lengthD: "xs [⊏⇩r] ys ⟹ size ys = size xs"
apply (unfold lesssub_def)
apply auto
done
lemma le_list_appendI: "a [⊑⇘r⇙] b ⟹ c [⊑⇘r⇙] d ⟹ a@c [⊑⇘r⇙] b@d"
apply (unfold Listn.le_def lesub_def)
apply (rule list_all2_appendI, assumption+)
done
lemma le_listI:
assumes "length a = length b"
assumes "⋀n. n < length a ⟹ a!n ⊑⇩r b!n"
shows "a [⊑⇘r⇙] b"
proof -
from assms have "list_all2 r a b"
by (simp add: list_all2_all_nthI lesub_def)
then show ?thesis by (simp add: Listn.le_def lesub_def)
qed
lemma listI: "⟦ size xs = n; set xs ⊆ A ⟧ ⟹ xs ∈ list n A"
apply (unfold list_def)
apply blast
done
lemma listE_length [simp]: "xs ∈ list n A ⟹ size xs = n"
apply (unfold list_def)
apply blast
done
lemma less_lengthI: "⟦ xs ∈ list n A; p < n ⟧ ⟹ p < size xs"
by simp
lemma listE_set [simp]: "xs ∈ list n A ⟹ set xs ⊆ A"
apply (unfold list_def)
apply blast
done
lemma list_0 [simp]: "list 0 A = {[]}"
apply (unfold list_def)
apply auto
done
lemma in_list_Suc_iff:
"(xs ∈ list (Suc n) A) = (∃y∈A. ∃ys ∈ list n A. xs = y#ys)"
apply (unfold list_def)
apply (case_tac "xs")
apply auto
done
lemma Cons_in_list_Suc [iff]:
"(x#xs ∈ list (Suc n) A) = (x∈A ∧ xs ∈ list n A)"
apply (simp add: in_list_Suc_iff)
done
lemma list_not_empty:
"∃a. a∈A ⟹ ∃xs. xs ∈ list n A"
apply (induct "n")
apply simp
apply (simp add: in_list_Suc_iff)
apply blast
done
lemma nth_in [rule_format, simp]:
"∀i n. size xs = n ⟶ set xs ⊆ A ⟶ i < n ⟶ (xs!i) ∈ A"
apply (induct "xs")
apply simp
apply (simp add: nth_Cons split: nat.split)
done
lemma listE_nth_in: "⟦ xs ∈ list n A; i < n ⟧ ⟹ xs!i ∈ A"
by auto
lemma listn_Cons_Suc [elim!]:
"l#xs ∈ list n A ⟹ (⋀n'. n = Suc n' ⟹ l ∈ A ⟹ xs ∈ list n' A ⟹ P) ⟹ P"
by (cases n) auto
lemma listn_appendE [elim!]:
"a@b ∈ list n A ⟹ (⋀n1 n2. n=n1+n2 ⟹ a ∈ list n1 A ⟹ b ∈ list n2 A ⟹ P) ⟹ P"
proof -
have "⋀n. a@b ∈ list n A ⟹ ∃n1 n2. n=n1+n2 ∧ a ∈ list n1 A ∧ b ∈ list n2 A"
(is "⋀n. ?list a n ⟹ ∃n1 n2. ?P a n n1 n2")
proof (induct a)
fix n assume "?list [] n"
hence "?P [] n 0 n" by simp
thus "∃n1 n2. ?P [] n n1 n2" by fast
next
fix n l ls
assume "?list (l#ls) n"
then obtain n' where n: "n = Suc n'" "l ∈ A" and n': "ls@b ∈ list n' A" by fastforce
assume "⋀n. ls @ b ∈ list n A ⟹ ∃n1 n2. n = n1 + n2 ∧ ls ∈ list n1 A ∧ b ∈ list n2 A"
from this and n' have "∃n1 n2. n' = n1 + n2 ∧ ls ∈ list n1 A ∧ b ∈ list n2 A" .
then obtain n1 n2 where "n' = n1 + n2" "ls ∈ list n1 A" "b ∈ list n2 A" by fast
with n have "?P (l#ls) n (n1+1) n2" by simp
thus "∃n1 n2. ?P (l#ls) n n1 n2" by fastforce
qed
moreover
assume "a@b ∈ list n A" "⋀n1 n2. n=n1+n2 ⟹ a ∈ list n1 A ⟹ b ∈ list n2 A ⟹ P"
ultimately
show ?thesis by blast
qed
lemma listt_update_in_list [simp, intro!]:
"⟦ xs ∈ list n A; x∈A ⟧ ⟹ xs[i := x] ∈ list n A"
apply (unfold list_def)
apply simp
done
lemma list_appendI [intro?]:
"⟦ a ∈ list n A; b ∈ list m A ⟧ ⟹ a @ b ∈ list (n+m) A"
by (unfold list_def) auto
lemma list_map [simp]: "(map f xs ∈ list (size xs) A) = (f ` set xs ⊆ A)"
by (unfold list_def) simp
lemma list_replicateI [intro]: "x ∈ A ⟹ replicate n x ∈ list n A"
by (induct n) auto
lemma plus_list_Nil [simp]: "[] [⊔⇘f⇙] xs = []"
apply (unfold plussub_def)
apply simp
done
lemma plus_list_Cons [simp]:
"(x#xs) [⊔⇘f⇙] ys = (case ys of [] ⇒ [] | y#ys ⇒ (x ⊔⇩f y)#(xs [⊔⇘f⇙] ys))"
by (simp add: plussub_def split: list.split)
lemma length_plus_list [rule_format, simp]:
"∀ys. size(xs [⊔⇘f⇙] ys) = min(size xs) (size ys)"
apply (induct xs)
apply simp
apply clarify
apply (simp (no_asm_simp) split: list.split)
done
lemma nth_plus_list [rule_format, simp]:
"∀xs ys i. size xs = n ⟶ size ys = n ⟶ i<n ⟶ (xs [⊔⇘f⇙] ys)!i = (xs!i) ⊔⇩f (ys!i)"
apply (induct n)
apply simp
apply clarify
apply (case_tac xs)
apply simp
apply (force simp add: nth_Cons split: list.split nat.split)
done
lemma (in Semilat) plus_list_ub1 [rule_format]:
"⟦ set xs ⊆ A; set ys ⊆ A; size xs = size ys ⟧
⟹ xs [⊑⇘r⇙] xs [⊔⇘f⇙] ys"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
lemma (in Semilat) plus_list_ub2:
"⟦set xs ⊆ A; set ys ⊆ A; size xs = size ys ⟧ ⟹ ys [⊑⇘r⇙] xs [⊔⇘f⇙] ys"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
lemma (in Semilat) plus_list_lub [rule_format]:
shows "∀xs ys zs. set xs ⊆ A ⟶ set ys ⊆ A ⟶ set zs ⊆ A
⟶ size xs = n ∧ size ys = n ⟶
xs [⊑⇘r⇙] zs ∧ ys [⊑⇘r⇙] zs ⟶ xs [⊔⇘f⇙] ys [⊑⇘r⇙] zs"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done
lemma (in Semilat) list_update_incr [rule_format]:
"x∈A ⟹ set xs ⊆ A ⟶
(∀i. i<size xs ⟶ xs [⊑⇘r⇙] xs[i := x ⊔⇩f xs!i])"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (induct xs)
apply simp
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: nth_Cons split: nat.split)
done
lemma acc_le_listI [intro!]:
"⟦ order r; acc r ⟧ ⟹ acc(Listn.le r)"
apply (unfold acc_def)
apply (subgoal_tac
"wf(UN n. {(ys,xs). size xs = n ∧ size ys = n ∧ xs <_(Listn.le r) ys})")
apply (erule wf_subset)
apply (blast intro: lesssub_lengthD)
apply (rule wf_UN)
prefer 2
apply (rename_tac m n)
apply (case_tac "m=n")
apply simp
apply (fast intro!: equals0I dest: not_sym)
apply (rename_tac n)
apply (induct_tac n)
apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal)
apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
apply clarify
apply (rename_tac M m)
apply (case_tac "∃x xs. size xs = k ∧ x#xs ∈ M")
prefer 2
apply (erule thin_rl)
apply (erule thin_rl)
apply blast
apply (erule_tac x = "{a. ∃xs. size xs = k ∧ a#xs:M}" in allE)
apply (erule impE)
apply blast
apply (thin_tac "∃x xs. P x xs" for P)
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. size ys = size xs ∧ maxA#ys ∈ M}" in allE)
apply (erule impE)
apply blast
apply clarify
apply (thin_tac "m ∈ M")
apply (thin_tac "maxA#xs ∈ M")
apply (rule bexI)
prefer 2
apply assumption
apply clarify
apply simp
apply blast
done
lemma closed_listI:
"closed S f ⟹ closed (list n S) (map2 f)"
apply (unfold closed_def)
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply simp
done
lemma Listn_sl_aux:
assumes "Semilat A r f" shows "semilat (Listn.sl n (A,r,f))"
proof -
interpret Semilat A r f by fact
show ?thesis
apply (unfold Listn.sl_def)
apply (simp (no_asm) only: semilat_Def split_conv)
apply (rule conjI)
apply simp
apply (rule conjI)
apply (simp only: closedI closed_listI)
apply (simp (no_asm) only: list_def)
apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
done
qed
lemma Listn_sl: "semilat L ⟹ semilat (Listn.sl n L)"
apply (cases L) apply simp
apply (drule Semilat.intro)
by (simp add: Listn_sl_aux split_tupled_all)
lemma coalesce_in_err_list [rule_format]:
"∀xes. xes ∈ list n (err A) ⟶ coalesce xes ∈ err(list n A)"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
apply force
done
lemma lem: "⋀x xs. x ⊔⇘(#)⇙ xs = x#xs"
by (simp add: plussub_def)
lemma coalesce_eq_OK1_D [rule_format]:
"semilat(err A, Err.le r, lift2 f) ⟹
∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
(∀zs. coalesce (xs [⊔⇘f⇙] ys) = OK zs ⟶ xs [⊑⇘r⇙] zs))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK1)
done
lemma coalesce_eq_OK2_D [rule_format]:
"semilat(err A, Err.le r, lift2 f) ⟹
∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
(∀zs. coalesce (xs [⊔⇘f⇙] ys) = OK zs ⟶ ys [⊑⇘r⇙] zs))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK2)
done
lemma lift2_le_ub:
"⟦ semilat(err A, Err.le r, lift2 f); x∈A; y∈A; x ⊔⇩f y = OK z;
u∈A; x ⊑⇩r u; y ⊑⇩r u ⟧ ⟹ z ⊑⇩r u"
apply (unfold semilat_Def plussub_def err_def')
apply (simp add: lift2_def)
apply clarify
apply (rotate_tac -3)
apply (erule thin_rl)
apply (erule thin_rl)
apply force
done
lemma coalesce_eq_OK_ub_D [rule_format]:
"semilat(err A, Err.le r, lift2 f) ⟹
∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
(∀zs us. coalesce (xs [⊔⇘f⇙] ys) = OK zs ∧ xs [⊑⇘r⇙] us ∧ ys [⊑⇘r⇙] us
∧ us ∈ list n A ⟶ zs [⊑⇘r⇙] us))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
apply clarify
apply (rule conjI)
apply (blast intro: lift2_le_ub)
apply blast
done
lemma lift2_eq_ErrD:
"⟦ x ⊔⇩f y = Err; semilat(err A, Err.le r, lift2 f); x∈A; y∈A ⟧
⟹ ¬(∃u∈A. x ⊑⇩r u ∧ y ⊑⇩r u)"
by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1])
lemma coalesce_eq_Err_D [rule_format]:
"⟦ semilat(err A, Err.le r, lift2 f) ⟧
⟹ ∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
coalesce (xs [⊔⇘f⇙] ys) = Err ⟶
¬(∃zs ∈ list n A. xs [⊑⇘r⇙] zs ∧ ys [⊑⇘r⇙] zs))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (blast dest: lift2_eq_ErrD)
done
lemma closed_err_lift2_conv:
"closed (err A) (lift2 f) = (∀x∈A. ∀y∈A. x ⊔⇩f y ∈ err A)"
apply (unfold closed_def)
apply (simp add: err_def')
done
lemma closed_map2_list [rule_format]:
"closed (err A) (lift2 f) ⟹
∀xs. xs ∈ list n A ⟶ (∀ys. ys ∈ list n A ⟶
map2 f xs ys ∈ list n (err A))"
apply (induct n)
apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: plussub_def closed_err_lift2_conv)
done
lemma closed_lift2_sup:
"closed (err A) (lift2 f) ⟹
closed (err (list n A)) (lift2 (sup f))"
by (fastforce simp add: closed_def plussub_def sup_def lift2_def
coalesce_in_err_list closed_map2_list
split: err.split)
lemma err_semilat_sup:
"err_semilat (A,r,f) ⟹
err_semilat (list n A, Listn.le r, sup f)"
apply (unfold Err.sl_def)
apply (simp only: split_conv)
apply (simp (no_asm) only: semilat_Def plussub_def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (rule conjI)
apply (drule Semilat.orderI [OF Semilat.intro])
apply simp
apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def' sup_def lift2_def)
apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
done
lemma err_semilat_upto_esl:
"⋀L. err_semilat L ⟹ err_semilat(upto_esl m L)"
apply (unfold Listn.upto_esl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (fastforce intro!: err_semilat_UnionI err_semilat_sup
dest: lesub_list_impl_same_size
simp add: plussub_def Listn.sup_def)
done
end
Theory Typing_Framework
section ‹Typing and Dataflow Analysis Framework›
theory Typing_Framework imports Semilattices begin
text ‹
The relationship between dataflow analysis and a welltyped-instruction predicate.
›
type_synonym
's step_type = "nat ⇒ 's ⇒ (nat × 's) list"
definition stable :: "'s ord ⇒ 's step_type ⇒ 's list ⇒ nat ⇒ bool"
where
"stable r step τs p ⟷ (∀(q,τ) ∈ set (step p (τs!p)). τ ⊑⇩r τs!q)"
definition stables :: "'s ord ⇒ 's step_type ⇒ 's list ⇒ bool"
where
"stables r step τs ⟷ (∀p < size τs. stable r step τs p)"
definition wt_step :: "'s ord ⇒ 's ⇒ 's step_type ⇒ 's list ⇒ bool"
where
"wt_step r T step τs ⟷ (∀p<size τs. τs!p ≠ T ∧ stable r step τs p)"
definition is_bcv :: "'s ord ⇒ 's ⇒ 's step_type ⇒ nat ⇒ 's set ⇒ ('s list ⇒ 's list) ⇒ bool"
where
"is_bcv r T step n A bcv ⟷ (∀τs⇩0 ∈ list n A.
(∀p<n. (bcv τs⇩0)!p ≠ T) = (∃τs ∈ list n A. τs⇩0 [⊑⇩r] τs ∧ wt_step r T step τs))"
end
Theory SemilatAlg
section ‹More on Semilattices›
theory SemilatAlg
imports Typing_Framework
begin
definition lesubstep_type :: "(nat × 's) set ⇒ 's ord ⇒ (nat × 's) set ⇒ bool"
("(_ /{⊑⇘_⇙} _)" [50, 0, 51] 50)
where "A {⊑⇘r⇙} B ≡ ∀(p,τ) ∈ A. ∃τ'. (p,τ') ∈ B ∧ τ ⊑⇩r τ'"
notation (ASCII)
lesubstep_type ("(_ /{<='__} _)" [50, 0, 51] 50)
primrec pluslussub :: "'a list ⇒ ('a ⇒ 'a ⇒ 'a) ⇒ 'a ⇒ 'a" ("(_ /⨆⇘_⇙ _)" [65, 0, 66] 65)
where
"pluslussub [] f y = y"
| "pluslussub (x#xs) f y = pluslussub xs f (x ⊔⇩f y)"
notation (ASCII)
pluslussub ("(_ /++'__ _)" [65, 1000, 66] 65)
definition bounded :: "'s step_type ⇒ nat ⇒ bool"
where
"bounded step n ⟷ (∀p<n. ∀τ. ∀(q,τ') ∈ set (step p τ). q<n)"
definition pres_type :: "'s step_type ⇒ nat ⇒ 's set ⇒ bool"
where
"pres_type step n A ⟷ (∀τ∈A. ∀p<n. ∀(q,τ') ∈ set (step p τ). τ' ∈ A)"
definition mono :: "'s ord ⇒ 's step_type ⇒ nat ⇒ 's set ⇒ bool"
where
"mono r step n A ⟷
(∀τ p τ'. τ ∈ A ∧ p<n ∧ τ ⊑⇩r τ' ⟶ set (step p τ) {⊑⇘r⇙} set (step p τ'))"
lemma [iff]: "{} {⊑⇘r⇙} B"
by (simp add: lesubstep_type_def)
lemma [iff]: "(A {⊑⇘r⇙} {}) = (A = {})"
by (cases "A={}") (auto simp add: lesubstep_type_def)
lemma lesubstep_union:
"⟦ A⇩1 {⊑⇘r⇙} B⇩1; A⇩2 {⊑⇘r⇙} B⇩2 ⟧ ⟹ A⇩1 ∪ A⇩2 {⊑⇘r⇙} B⇩1 ∪ B⇩2"
by (auto simp add: lesubstep_type_def)
lemma pres_typeD:
"⟦ pres_type step n A; s∈A; p<n; (q,s')∈set (step p s) ⟧ ⟹ s' ∈ A"
by (unfold pres_type_def, blast)
lemma monoD:
"⟦ mono r step n A; p < n; s∈A; s ⊑⇩r t ⟧ ⟹ set (step p s) {⊑⇘r⇙} set (step p t)"
by (unfold mono_def, blast)
lemma boundedD:
"⟦ bounded step n; p < n; (q,t) ∈ set (step p xs) ⟧ ⟹ q < n"
by (unfold bounded_def, blast)
lemma lesubstep_type_refl [simp, intro]:
"(⋀x. x ⊑⇩r x) ⟹ A {⊑⇘r⇙} A"
by (unfold lesubstep_type_def) auto
lemma lesub_step_typeD:
"A {⊑⇘r⇙} B ⟹ (x,y) ∈ A ⟹ ∃y'. (x, y') ∈ B ∧ y ⊑⇩r y'"
by (unfold lesubstep_type_def) blast
lemma list_update_le_listI [rule_format]:
"set xs ⊆ A ⟶ set ys ⊆ A ⟶ xs [⊑⇩r] ys ⟶ p < size xs ⟶
x ⊑⇩r ys!p ⟶ semilat(A,r,f) ⟶ x∈A ⟶
xs[p := x ⊔⇩f xs!p] [⊑⇩r] ys"
apply (simp only: Listn.le_def lesub_def semilat_def)
apply (simp add: list_all2_conv_all_nth nth_list_update)
done
lemma plusplus_closed: assumes "Semilat A r f" shows
"⋀y. ⟦ set x ⊆ A; y ∈ A⟧ ⟹ x ⨆⇘f⇙ y ∈ A"
proof (induct x)
interpret Semilat A r f by fact
show "⋀y. y ∈ A ⟹ [] ⨆⇘f⇙ y ∈ A" by simp
fix y x xs
assume y: "y ∈ A" and xxs: "set (x#xs) ⊆ A"
assume IH: "⋀y. ⟦ set xs ⊆ A; y ∈ A⟧ ⟹ xs ⨆⇘f⇙ y ∈ A"
from xxs obtain x: "x ∈ A" and xs: "set xs ⊆ A" by simp
from x y have "x ⊔⇘f⇙ y ∈ A" ..
with xs have "xs ⨆⇘f⇙ (x ⊔⇘f⇙ y) ∈ A" by (rule IH)
thus "x#xs ⨆⇘f⇙ y ∈ A" by simp
qed
lemma (in Semilat) pp_ub2:
"⋀y. ⟦ set x ⊆ A; y ∈ A⟧ ⟹ y ⊑⇘r⇙ x ⨆⇘f⇙ y"
proof (induct x)
from semilat show "⋀y. y ⊑⇘r⇙ [] ⨆⇘f⇙ y" by simp
fix y a l assume y: "y ∈ A" and "set (a#l) ⊆ A"
then obtain a: "a ∈ A" and x: "set l ⊆ A" by simp
assume "⋀y. ⟦set l ⊆ A; y ∈ A⟧ ⟹ y ⊑⇘r⇙ l ⨆⇘f⇙ y"
from this and x have IH: "⋀y. y ∈ A ⟹ y ⊑⇘r⇙ l ⨆⇘f⇙ y" .
from a y have "y ⊑⇘r⇙ a ⊔⇘f⇙ y" ..
also from a y have "a ⊔⇘f⇙ y ∈ A" ..
hence "(a ⊔⇘f⇙ y) ⊑⇘r⇙ l ⨆⇘f⇙ (a ⊔⇘f⇙ y)" by (rule IH)
finally have "y ⊑⇘r⇙ l ⨆⇘f⇙ (a ⊔⇘f⇙ y)" .
thus "y ⊑⇘r⇙ (a#l) ⨆⇘f⇙ y" by simp
qed
lemma (in Semilat) pp_ub1:
shows "⋀y. ⟦set ls ⊆ A; y ∈ A; x ∈ set ls⟧ ⟹ x ⊑⇘r⇙ ls ⨆⇘f⇙ y"
proof (induct ls)
show "⋀y. x ∈ set [] ⟹ x ⊑⇘r⇙ [] ⨆⇘f⇙ y" by simp
fix y s ls
assume "set (s#ls) ⊆ A"
then obtain s: "s ∈ A" and ls: "set ls ⊆ A" by simp
assume y: "y ∈ A"
assume "⋀y. ⟦set ls ⊆ A; y ∈ A; x ∈ set ls⟧ ⟹ x ⊑⇘r⇙ ls ⨆⇘f⇙ y"
from this and ls have IH: "⋀y. x ∈ set ls ⟹ y ∈ A ⟹ x ⊑⇘r⇙ ls ⨆⇘f⇙ y" .
assume "x ∈ set (s#ls)"
then obtain xls: "x = s ∨ x ∈ set ls" by simp
moreover {
assume xs: "x = s"
from s y have "s ⊑⇘r⇙ s ⊔⇘f⇙ y" ..
also from s y have "s ⊔⇘f⇙ y ∈ A" ..
with ls have "(s ⊔⇘f⇙ y) ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" by (rule pp_ub2)
finally have "s ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" .
with xs have "x ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" by simp
}
moreover {
assume "x ∈ set ls"
hence "⋀y. y ∈ A ⟹ x ⊑⇘r⇙ ls ⨆⇘f⇙ y" by (rule IH)
moreover from s y have "s ⊔⇘f⇙ y ∈ A" ..
ultimately have "x ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" .
}
ultimately
have "x ⊑⇘r⇙ ls ⨆⇘f⇙ (s ⊔⇘f⇙ y)" by blast
thus "x ⊑⇘r⇙ (s#ls) ⨆⇘f⇙ y" by simp
qed
lemma (in Semilat) pp_lub:
assumes z: "z ∈ A"
shows
"⋀y. y ∈ A ⟹ set xs ⊆ A ⟹ ∀x ∈ set xs. x ⊑⇘r⇙ z ⟹ y ⊑⇘r⇙ z ⟹ xs ⨆⇘f⇙ y ⊑⇘r⇙ z"
proof (induct xs)
fix y assume "y ⊑⇘r⇙ z" thus "[] ⨆⇘f⇙ y ⊑⇘r⇙ z" by simp
next
fix y l ls assume y: "y ∈ A" and "set (l#ls) ⊆ A"
then obtain l: "l ∈ A" and ls: "set ls ⊆ A" by auto
assume "∀x ∈ set (l#ls). x ⊑⇘r⇙ z"
then obtain lz: "l ⊑⇘r⇙ z" and lsz: "∀x ∈ set ls. x ⊑⇘r⇙ z" by auto
assume "y ⊑⇘r⇙ z" with lz have "l ⊔⇘f⇙ y ⊑⇘r⇙ z" using l y z ..
moreover
from l y have "l ⊔⇘f⇙ y ∈ A" ..
moreover
assume "⋀y. y ∈ A ⟹ set ls ⊆ A ⟹ ∀x ∈ set ls. x ⊑⇘r⇙ z ⟹ y ⊑⇘r⇙ z
⟹ ls ⨆⇘f⇙ y ⊑⇘r⇙ z"
ultimately
have "ls ⨆⇘f⇙ (l ⊔⇘f⇙ y) ⊑⇘r⇙ z" using ls lsz by -
thus "(l#ls) ⨆⇘f⇙ y ⊑⇘r⇙ z" by simp
qed
lemma ub1': assumes "Semilat A r f"
shows "⟦∀(p,s) ∈ set S. s ∈ A; y ∈ A; (a,b) ∈ set S⟧
⟹ b ⊑⇘r⇙ map snd [(p', t') ← S. p' = a] ⨆⇘f⇙ y"
proof -
interpret Semilat A r f by fact
let "b ⊑⇘r⇙ ?map ⨆⇘f⇙ y" = ?thesis
assume "y ∈ A"
moreover
assume "∀(p,s) ∈ set S. s ∈ A"
hence "set ?map ⊆ A" by auto
moreover
assume "(a,b) ∈ set S"
hence "b ∈ set ?map" by (induct S, auto)
ultimately
show ?thesis by - (rule pp_ub1)
qed
lemma plusplus_empty:
"∀s'. (q, s') ∈ set S ⟶ s' ⊔⇘f⇙ ss ! q = ss ! q ⟹
(map snd [(p', t') ← S. p' = q] ⨆⇘f⇙ ss ! q) = ss ! q"
apply (induct S)
apply auto
done
end
Theory Typing_Framework_err
section ‹Lifting the Typing Framework to err, app, and eff›
theory Typing_Framework_err imports Typing_Framework SemilatAlg begin
definition wt_err_step :: "'s ord ⇒ 's err step_type ⇒ 's err list ⇒ bool"
where
"wt_err_step r step τs ⟷ wt_step (Err.le r) Err step τs"
definition wt_app_eff :: "'s ord ⇒ (nat ⇒ 's ⇒ bool) ⇒ 's step_type ⇒ 's list ⇒ bool"
where
"wt_app_eff r app step τs ⟷
(∀p < size τs. app p (τs!p) ∧ (∀(q,τ) ∈ set (step p (τs!p)). τ <=_r τs!q))"
definition map_snd :: "('b ⇒ 'c) ⇒ ('a × 'b) list ⇒ ('a × 'c) list"
where
"map_snd f = map (λ(x,y). (x, f y))"
definition error :: "nat ⇒ (nat × 'a err) list"
where
"error n = map (λx. (x,Err)) [0..<n]"
definition err_step :: "nat ⇒ (nat ⇒ 's ⇒ bool) ⇒ 's step_type ⇒ 's err step_type"
where
"err_step n app step p t =
(case t of
Err ⇒ error n
| OK τ ⇒ if app p τ then map_snd OK (step p τ) else error n)"
definition app_mono :: "'s ord ⇒ (nat ⇒ 's ⇒ bool) ⇒ nat ⇒ 's set ⇒ bool"
where
"app_mono r app n A ⟷
(∀s p t. s ∈ A ∧ p < n ∧ s ⊑⇩r t ⟶ app p t ⟶ app p s)"
lemmas err_step_defs = err_step_def map_snd_def error_def
lemma bounded_err_stepD:
"⟦ bounded (err_step n app step) n;
p < n; app p a; (q,b) ∈ set (step p a) ⟧ ⟹ q < n"
apply (simp add: bounded_def err_step_def)
apply (erule allE, erule impE, assumption)
apply (erule_tac x = "OK a" in allE, drule bspec)
apply (simp add: map_snd_def)
apply fast
apply simp
done
lemma in_map_sndD: "(a,b) ∈ set (map_snd f xs) ⟹ ∃b'. (a,b') ∈ set xs"
apply (induct xs)
apply (auto simp add: map_snd_def)
done
lemma bounded_err_stepI:
"∀p. p < n ⟶ (∀s. ap p s ⟶ (∀(q,s') ∈ set (step p s). q < n))
⟹ bounded (err_step n ap step) n"
apply (clarsimp simp: bounded_def err_step_def split: err.splits)
apply (simp add: error_def image_def)
apply (blast dest: in_map_sndD)
done
lemma bounded_lift:
"bounded step n ⟹ bounded (err_step n app step) n"
apply (unfold bounded_def err_step_def error_def)
apply clarify
apply (erule allE, erule impE, assumption)
apply (case_tac τ)
apply (auto simp add: map_snd_def split: if_split_asm)
done
lemma le_list_map_OK [simp]:
"⋀b. (map OK a [⊑⇘Err.le r⇙] map OK b) = (a [⊑⇩r] b)"
apply (induct a)
apply simp
apply simp
apply (case_tac b)
apply simp
apply simp
done
lemma map_snd_lessI:
"set xs {⊑⇘r⇙} set ys ⟹ set (map_snd OK xs) {⊑⇘Err.le r⇙} set (map_snd OK ys)"
apply (induct xs)
apply (unfold lesubstep_type_def map_snd_def)
apply auto
done
lemma mono_lift:
"⟦ order r; app_mono r app n A; bounded (err_step n app step) n;
∀s p t. s ∈ A ∧ p < n ∧ s ⊑⇩r t ⟶ app p t ⟶ set (step p s) {⊑⇘r⇙} set (step p t) ⟧
⟹ mono (Err.le r) (err_step n app step) n (err A)"
apply (simp only: app_mono_def SemilatAlg.mono_def err_step_def)
apply clarify
apply (case_tac τ)
apply simp
apply simp
apply (case_tac τ')
apply simp
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
apply simp
apply (erule allE, erule allE, erule allE, erule impE)
apply (rule conjI, assumption)
apply (rule conjI, assumption)
apply assumption
apply (rule conjI)
apply clarify
apply (erule allE, erule allE, erule allE, erule impE)
apply (rule conjI, assumption)
apply (rule conjI, assumption)
apply assumption
apply (erule impE, assumption)
apply (rule map_snd_lessI, assumption)
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
done
lemma in_errorD: "(x,y) ∈ set (error n) ⟹ y = Err"
by (auto simp add: error_def)
lemma pres_type_lift:
"∀s∈A. ∀p. p < n ⟶ app p s ⟶ (∀(q, s')∈set (step p s). s' ∈ A)
⟹ pres_type (err_step n app step) n (err A)"
apply (unfold pres_type_def err_step_def)
apply clarify
apply (case_tac b)
apply simp
apply (case_tac τ)
apply simp
apply (drule in_errorD)
apply simp
apply (simp add: map_snd_def split: if_split_asm)
apply fast
apply (drule in_errorD)
apply simp
done
lemma wt_err_imp_wt_app_eff:
assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
assumes b: "bounded (err_step (size ts) app step) (size ts)"
shows "wt_app_eff r app step (map ok_val ts)"
proof (unfold wt_app_eff_def, intro strip, rule conjI)
fix p assume "p < size (map ok_val ts)"
hence lp: "p < size ts" by simp
hence ts: "0 < size ts" by (cases p) auto
hence err: "(0,Err) ∈ set (error (size ts))" by (simp add: error_def)
from wt lp
have [intro?]: "⋀p. p < size ts ⟹ ts ! p ≠ Err"
by (unfold wt_err_step_def wt_step_def) simp
show app: "app p (map ok_val ts ! p)"
proof (rule ccontr)
from wt lp obtain s where
OKp: "ts ! p = OK s" and
less: "∀(q,t) ∈ set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
by (unfold wt_err_step_def wt_step_def stable_def)
(auto iff: not_Err_eq)
assume "¬ app p (map ok_val ts ! p)"
with OKp lp have "¬ app p s" by simp
with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)"
by (simp add: err_step_def)
with err ts obtain q where
"(q,Err) ∈ set (err_step (size ts) app step p (ts!p))" and
q: "q < size ts" by auto
with less have "ts!q = Err" by auto
moreover from q have "ts!q ≠ Err" ..
ultimately show False by blast
qed
show "∀(q,t)∈set(step p (map ok_val ts ! p)). t ⊑⇩r map ok_val ts ! q"
proof clarify
fix q t assume q: "(q,t) ∈ set (step p (map ok_val ts ! p))"
from wt lp q
obtain s where
OKp: "ts ! p = OK s" and
less: "∀(q,t) ∈ set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
by (unfold wt_err_step_def wt_step_def stable_def)
(auto iff: not_Err_eq)
from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
hence "ts!q ≠ Err" ..
then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)
from lp lq OKp OKq app less q
show "t ⊑⇩r map ok_val ts ! q"
by (auto simp add: err_step_def map_snd_def)
qed
qed
lemma wt_app_eff_imp_wt_err:
assumes app_eff: "wt_app_eff r app step ts"
assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
fix p assume "p < size (map OK ts)"
hence p: "p < size ts" by simp
thus "map OK ts ! p ≠ Err" by simp
{ fix q t
assume q: "(q,t) ∈ set (err_step (size ts) app step p (map OK ts ! p))"
with p app_eff obtain
"app p (ts ! p)" "∀(q,t) ∈ set (step p (ts!p)). t ⊑⇩r ts!q"
by (unfold wt_app_eff_def) blast
moreover
from q p bounded have "q < size ts"
by - (rule boundedD)
hence "map OK ts ! q = OK (ts!q)" by simp
moreover
have "p < size ts" by (rule p)
moreover note q
ultimately
have "t ⊑⇘Err.le r⇙ map OK ts ! q"
by (auto simp add: err_step_def map_snd_def)
}
thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
by (unfold stable_def) blast
qed
end
Theory Kildall
section ‹Kildall's Algorithm \label{sec:Kildall}›
theory Kildall
imports SemilatAlg
begin
primrec propa :: "'s binop ⇒ (nat × 's) list ⇒ 's list ⇒ nat set ⇒ 's list * nat set"
where
"propa f [] τs w = (τs,w)"
| "propa f (q'#qs) τs w = (let (q,τ) = q';
u = τ ⊔⇘f⇙ τs!q;
w' = (if u = τs!q then w else insert q w)
in propa f qs (τs[q := u]) w')"
definition iter :: "'s binop ⇒ 's step_type ⇒
's list ⇒ nat set ⇒ 's list × nat set"
where
"iter f step τs w =
while (λ(τs,w). w ≠ {})
(λ(τs,w). let p = SOME p. p ∈ w
in propa f (step p (τs!p)) τs (w-{p}))
(τs,w)"
definition unstables :: "'s ord ⇒ 's step_type ⇒ 's list ⇒ nat set"
where
"unstables r step τs = {p. p < size τs ∧ ¬stable r step τs p}"
definition kildall :: "'s ord ⇒ 's binop ⇒ 's step_type ⇒ 's list ⇒ 's list"
where
"kildall r f step τs = fst(iter f step τs (unstables r step τs))"
primrec merges :: "'s binop ⇒ (nat × 's) list ⇒ 's list ⇒ 's list"
where
"merges f [] τs = τs"
| "merges f (p'#ps) τs = (let (p,τ) = p' in merges f ps (τs[p := τ ⊔⇘f⇙ τs!p]))"
lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]
lemma (in Semilat) nth_merges:
"⋀ss. ⟦p < length ss; ss ∈ list n A; ∀(p,t)∈set ps. p<n ∧ t∈A ⟧ ⟹
(merges f ps ss)!p = map snd [(p',t') ← ps. p'=p] ⨆⇘f⇙ ss!p"
(is "⋀ss. ⟦_; _; ?steptype ps⟧ ⟹ ?P ss ps")
proof (induct ps)
show "⋀ss. ?P ss []" by simp
fix ss p' ps'
assume ss: "ss ∈ list n A"
assume l: "p < length ss"
assume "?steptype (p'#ps')"
then obtain a b where
p': "p'=(a,b)" and ab: "a<n" "b∈A" and ps': "?steptype ps'"
by (cases p') auto
assume "⋀ss. p< length ss ⟹ ss ∈ list n A ⟹ ?steptype ps' ⟹ ?P ss ps'"
hence IH: "⋀ss. ss ∈ list n A ⟹ p < length ss ⟹ ?P ss ps'" using ps' by iprover
from ss ab
have "ss[a := b ⊔⇘f⇙ ss!a] ∈ list n A" by (simp add: closedD)
moreover
with l have "p < length (ss[a := b ⊔⇘f⇙ ss!a])" by simp
ultimately
have "?P (ss[a := b ⊔⇘f⇙ ss!a]) ps'" by (rule IH)
with p' l
show "?P ss (p'#ps')" by simp
qed
lemma length_merges [simp]:
"⋀ss. size(merges f ps ss) = size ss"
by (induct ps, auto)
lemma (in Semilat) merges_preserves_type_lemma:
shows "∀xs. xs ∈ list n A ⟶ (∀(p,x) ∈ set ps. p<n ∧ x∈A)
⟶ merges f ps xs ∈ list n A"
apply (insert closedI)
apply (unfold closed_def)
apply (induct ps)
apply simp
apply clarsimp
done
lemma (in Semilat) merges_preserves_type [simp]:
"⟦ xs ∈ list n A; ∀(p,x) ∈ set ps. p<n ∧ x∈A ⟧
⟹ merges f ps xs ∈ list n A"
by (simp add: merges_preserves_type_lemma)
lemma (in Semilat) merges_incr_lemma:
"∀xs. xs ∈ list n A ⟶ (∀(p,x)∈set ps. p<size xs ∧ x ∈ A) ⟶ xs [⊑⇘r⇙] merges f ps xs"
apply (induct ps)
apply simp
apply simp
apply clarify
apply (rule order_trans)
apply simp
apply (erule list_update_incr)
apply simp
apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done
lemma (in Semilat) merges_incr:
"⟦ xs ∈ list n A; ∀(p,x)∈set ps. p<size xs ∧ x ∈ A ⟧
⟹ xs [⊑⇘r⇙] merges f ps xs"
by (simp add: merges_incr_lemma)
lemma (in Semilat) merges_same_conv [rule_format]:
"(∀xs. xs ∈ list n A ⟶ (∀(p,x)∈set ps. p<size xs ∧ x∈A) ⟶
(merges f ps xs = xs) = (∀(p,x)∈set ps. x ⊑⇘r⇙ xs!p))"
apply (induct_tac ps)
apply simp
apply clarsimp
apply (rename_tac p x ps xs)
apply (rule iffI)
apply (rule context_conjI)
apply (subgoal_tac "xs[p := x ⊔⇘f⇙ xs!p] [⊑⇘r⇙] xs")
apply (force dest!: le_listD simp add: nth_list_update)
apply (erule subst, rule merges_incr)
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
apply clarify
apply (rule conjI)
apply simp
apply (blast dest: boundedD)
apply blast
apply clarify
apply (erule allE)
apply (erule impE)
apply assumption
apply (drule bspec)
apply assumption
apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
apply blast
apply clarify
apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
done
lemma (in Semilat) list_update_le_listI [rule_format]:
"set xs ⊆ A ⟶ set ys ⊆ A ⟶ xs [⊑⇘r⇙] ys ⟶ p < size xs ⟶
x ⊑⇘r⇙ ys!p ⟶ x∈A ⟶ xs[p := x ⊔⇘f⇙ xs!p] [⊑⇘r⇙] ys"
apply (insert semilat)
apply (simp only: Listn.le_def lesub_def semilat_def)
apply (simp add: list_all2_conv_all_nth nth_list_update)
done
lemma (in Semilat) merges_pres_le_ub:
assumes "set ts ⊆ A" "set ss ⊆ A"
"∀(p,t)∈set ps. t ⊑⇘r⇙ ts!p ∧ t ∈ A ∧ p < size ts" "ss [⊑⇘r⇙] ts"
shows "merges f ps ss [⊑⇘r⇙] ts"
proof -
{ fix t ts ps
have
"⋀qs. ⟦set ts ⊆ A; ∀(p,t)∈set ps. t ⊑⇘r⇙ ts!p ∧ t ∈ A ∧ p< size ts ⟧ ⟹
set qs ⊆ set ps ⟶
(∀ss. set ss ⊆ A ⟶ ss [⊑⇘r⇙] ts ⟶ merges f qs ss [⊑⇘r⇙] ts)"
apply (induct_tac qs)
apply simp
apply (simp (no_asm_simp))
apply clarify
apply simp
apply (erule allE, erule impE, erule_tac [2] mp)
apply (drule bspec, assumption)
apply (simp add: closedD)
apply (drule bspec, assumption)
apply (simp add: list_update_le_listI)
done
} note this [dest]
from assms show ?thesis by blast
qed
lemma decomp_propa:
"⋀ss w. (∀(q,t)∈set qs. q < size ss) ⟹
propa f qs ss w =
(merges f qs ss, {q. ∃t.(q,t)∈set qs ∧ t ⊔⇘f⇙ ss!q ≠ ss!q} ∪ w)"
apply (induct qs)
apply simp
apply (simp (no_asm))
apply clarify
apply simp
apply (rule conjI)
apply blast
apply (simp add: nth_list_update)
apply blast
done
lemma (in Semilat) stable_pres_lemma:
shows "⟦pres_type step n A; bounded step n;
ss ∈ list n A; p ∈ w; ∀q∈w. q < n;
∀q. q < n ⟶ q ∉ w ⟶ stable r step ss q; q < n;
∀s'. (q,s') ∈ set (step p (ss!p)) ⟶ s' ⊔⇘f⇙ ss!q = ss!q;
q ∉ w ∨ q = p ⟧
⟹ stable r step (merges f (step p (ss!p)) ss) q"
apply (unfold stable_def)
apply (subgoal_tac "∀s'. (q,s') ∈ set (step p (ss!p)) ⟶ s' : A")
prefer 2
apply clarify
apply (erule pres_typeD)
prefer 3 apply assumption
apply (rule listE_nth_in)
apply assumption
apply simp
apply simp
apply simp
apply clarify
apply (subst nth_merges)
apply simp
apply (blast dest: boundedD)
apply assumption
apply clarify
apply (rule conjI)
apply (blast dest: boundedD)
apply (erule pres_typeD)
prefer 3 apply assumption
apply simp
apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
apply (frule nth_merges [of q _ _ "step p (ss!p)"])
apply assumption
apply clarify
apply (rule conjI)
apply (blast dest: boundedD)
apply (erule pres_typeD)
prefer 3 apply assumption
apply simp
apply simp
apply (drule_tac P = "λx. (a, b) ∈ set (step q x)" in subst)
apply assumption
apply (simp add: plusplus_empty)
apply (cases "q ∈ w")
apply simp
apply (rule ub1')
apply (rule Semilat.intro)
apply (rule semilat)
apply clarify
apply (rule pres_typeD)
apply assumption
prefer 3 apply assumption
apply (blast intro: listE_nth_in dest: boundedD)
apply (blast intro: pres_typeD dest: boundedD)
apply (blast intro: listE_nth_in dest: boundedD)
apply assumption
apply simp
apply (erule allE, erule impE, assumption, erule impE, assumption)
apply (rule order_trans)
apply simp
defer
apply (rule pp_ub2)
apply simp
apply clarify
apply simp
apply (rule pres_typeD)
apply assumption
prefer 3 apply assumption
apply (blast intro: listE_nth_in dest: boundedD)
apply (blast intro: pres_typeD dest: boundedD)
apply (blast intro: listE_nth_in dest: boundedD)
apply blast
done
lemma (in Semilat) merges_bounded_lemma:
"⟦ mono r step n A; bounded step n;
∀(p',s') ∈ set (step p (ss!p)). s' ∈ A; ss ∈ list n A; ts ∈ list n A; p < n;
ss [⊑⇩r] ts; ∀p. p < n ⟶ stable r step ts p ⟧
⟹ merges f (step p (ss!p)) ss [⊑⇩r] ts"
apply (unfold stable_def)
apply (rule merges_pres_le_ub)
apply simp
apply simp
prefer 2 apply assumption
apply clarsimp
apply (drule boundedD, assumption+)
apply (erule allE, erule impE, assumption)
apply (drule bspec, assumption)
apply simp
apply (drule monoD [of _ _ _ _ p "ss!p" "ts!p"])
apply assumption
apply simp
apply (simp add: le_listD)
apply (drule lesub_step_typeD, assumption)
apply clarify
apply (drule bspec, assumption)
apply simp
apply (blast intro: order_trans)
done
lemma termination_lemma: assumes "Semilat A r f"
shows "⟦ ss ∈ list n A; ∀(q,t)∈set qs. q<n ∧ t∈A; p∈w ⟧ ⟹
ss [⊏⇩r] merges f qs ss ∨
merges f qs ss = ss ∧ {q. ∃t. (q,t)∈set qs ∧ t ⊔⇘f⇙ ss!q ≠ ss!q} ∪ (w-{p}) ⊂ w"
(is "PROP ?P")
proof -
interpret Semilat A r f by fact
show "PROP ?P"
apply(insert semilat)
apply (unfold lesssub_def)
apply (simp (no_asm_simp) add: merges_incr)
apply (rule impI)
apply (rule merges_same_conv [THEN iffD1, elim_format])
apply assumption+
defer
apply (rule sym, assumption)
defer apply simp
apply (subgoal_tac "∀q t. ¬((q, t) ∈ set qs ∧ t ⊔⇘f⇙ ss ! q ≠ ss ! q)")
apply (blast intro!: psubsetI elim: equalityE)
apply clarsimp
apply (drule bspec, assumption)
apply (drule bspec, assumption)
apply clarsimp
done
qed
lemma iter_properties[rule_format]: assumes "Semilat A r f"
shows "⟦ acc r; pres_type step n A; mono r step n A;
bounded step n; ∀p∈w0. p < n; ss0 ∈ list n A;
∀p<n. p ∉ w0 ⟶ stable r step ss0 p ⟧ ⟹
iter f step ss0 w0 = (ss',w')
⟶
ss' ∈ list n A ∧ stables r step ss' ∧ ss0 [⊑⇩r] ss' ∧
(∀ts∈list n A. ss0 [⊑⇩r] ts ∧ stables r step ts ⟶ ss' [⊑⇩r] ts)"
(is "PROP ?P")
proof -
interpret Semilat A r f by fact
show "PROP ?P"
apply(insert semilat)
apply (unfold iter_def stables_def)
apply (rule_tac P = "λ(ss,w).
ss ∈ list n A ∧ (∀p<n. p ∉ w ⟶ stable r step ss p) ∧ ss0 [⊑⇩r] ss ∧
(∀ts∈list n A. ss0 [⊑⇩r] ts ∧ stables r step ts ⟶ ss [⊑⇩r] ts) ∧
(∀p∈w. p < n)" and
r = "{(ss',ss) . ss [⊏⇩r] ss'} <*lex*> finite_psubset"
in while_rule)
apply (simp add:stables_def)
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "(SOME p. p ∈ w) ∈ w")
prefer 2 apply (fast intro: someI)
apply(subgoal_tac "∀(q,t) ∈ set (step (SOME p. p ∈ w) (ss ! (SOME p. p ∈ w))). q < length ss ∧ t ∈ A")
prefer 2
apply clarify
apply (rule conjI)
apply(clarsimp, blast dest!: boundedD)
apply (erule pres_typeD)
prefer 3
apply assumption
apply (erule listE_nth_in)
apply blast
apply blast
apply (subst decomp_propa)
apply blast
apply simp
apply (rule conjI)
apply (rule merges_preserves_type)
apply blast
apply clarify
apply (rule conjI)
apply(clarsimp, blast dest!: boundedD)
apply (erule pres_typeD)
prefer 3
apply assumption
apply (erule listE_nth_in)
apply blast
apply blast
apply (rule conjI)
apply clarify
apply (blast intro!: stable_pres_lemma)
apply (rule conjI)
apply (blast intro!: merges_incr intro: le_list_trans)
apply (rule conjI)
apply clarsimp
apply (blast intro!: merges_bounded_lemma)
apply (blast dest!: boundedD)
apply(clarsimp simp add: stables_def split_paired_all)
apply (rule wf_lex_prod)
apply (insert orderI [THEN acc_le_listI])
apply (simp only: acc_def lesssub_def)
apply (rule wf_finite_psubset)
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "(SOME p. p ∈ w) ∈ w")
prefer 2 apply (fast intro: someI)
apply(subgoal_tac "∀(q,t) ∈ set (step (SOME p. p ∈ w) (ss ! (SOME p. p ∈ w))). q < length ss ∧ t ∈ A")
prefer 2
apply clarify
apply (rule conjI)
apply(clarsimp, blast dest!: boundedD)
apply (erule pres_typeD)
prefer 3
apply assumption
apply (erule listE_nth_in)
apply blast
apply blast
apply (subst decomp_propa)
apply blast
apply clarify
apply (simp del: listE_length
add: lex_prod_def finite_psubset_def
bounded_nat_set_is_finite)
apply (rule termination_lemma)
apply (rule assms)
apply assumption+
defer
apply assumption
apply clarsimp
done
qed
lemma kildall_properties: assumes "Semilat A r f"
shows "⟦ acc r; pres_type step n A; mono r step n A;
bounded step n; ss0 ∈ list n A ⟧ ⟹
kildall r f step ss0 ∈ list n A ∧
stables r step (kildall r f step ss0) ∧
ss0 [⊑⇩r] kildall r f step ss0 ∧
(∀ts∈list n A. ss0 [⊑⇩r] ts ∧ stables r step ts ⟶
kildall r f step ss0 [⊑⇩r] ts)"
(is "PROP ?P")
proof -
interpret Semilat A r f by fact
show "PROP ?P"
apply (unfold kildall_def)
apply(case_tac "iter f step ss0 (unstables r step ss0)")
apply(simp)
apply (rule iter_properties)
apply (simp_all add: unstables_def stable_def)
apply (rule Semilat.intro)
apply (rule semilat)
done
qed
lemma is_bcv_kildall: assumes "Semilat A r f"
shows "⟦ acc r; top r T; pres_type step n A; bounded step n; mono r step n A ⟧
⟹ is_bcv r T step n A (kildall r f step)" (is "PROP ?P")
proof -
interpret Semilat A r f by fact
show "PROP ?P"
apply(unfold is_bcv_def wt_step_def)
apply(insert ‹Semilat A r f› semilat kildall_properties[of A])
apply(simp add:stables_def)
apply clarify
apply(subgoal_tac "kildall r f step τs⇩0 ∈ list n A")
prefer 2 apply (simp(no_asm_simp))
apply (rule iffI)
apply (rule_tac x = "kildall r f step τs⇩0" in bexI)
apply (rule conjI)
apply (blast)
apply (simp (no_asm_simp))
apply(assumption)
apply clarify
apply(subgoal_tac "kildall r f step τs⇩0!p <=_r τs!p")
apply simp
apply (blast intro!: le_listD less_lengthI)
done
qed
end
Theory LBVSpec
section ‹The Lightweight Bytecode Verifier›
theory LBVSpec
imports SemilatAlg Opt
begin
type_synonym
's certificate = "'s list"
primrec merge :: "'s certificate ⇒ 's binop ⇒ 's ord ⇒ 's ⇒ nat ⇒ (nat × 's) list ⇒ 's ⇒ 's"
where
"merge cert f r T pc [] x = x"
| "merge cert f r T pc (s#ss) x = merge cert f r T pc ss (let (pc',s') = s in
if pc'=pc+1 then s' ⊔⇩f x
else if s' ⊑⇩r cert!pc' then x
else T)"
definition wtl_inst :: "'s certificate ⇒ 's binop ⇒ 's ord ⇒ 's ⇒
's step_type ⇒ nat ⇒ 's ⇒ 's"
where
"wtl_inst cert f r T step pc s = merge cert f r T pc (step pc s) (cert!(pc+1))"
definition wtl_cert :: "'s certificate ⇒ 's binop ⇒ 's ord ⇒ 's ⇒ 's ⇒
's step_type ⇒ nat ⇒ 's ⇒ 's"
where
"wtl_cert cert f r T B step pc s =
(if cert!pc = B then
wtl_inst cert f r T step pc s
else
if s ⊑⇩r cert!pc then wtl_inst cert f r T step pc (cert!pc) else T)"
primrec wtl_inst_list :: "'a list ⇒ 's certificate ⇒ 's binop ⇒ 's ord ⇒ 's ⇒ 's ⇒
's step_type ⇒ nat ⇒ 's ⇒ 's"
where
"wtl_inst_list [] cert f r T B step pc s = s"
| "wtl_inst_list (i#is) cert f r T B step pc s =
(let s' = wtl_cert cert f r T B step pc s in
if s' = T ∨ s = T then T else wtl_inst_list is cert f r T B step (pc+1) s')"
definition cert_ok :: "'s certificate ⇒ nat ⇒ 's ⇒ 's ⇒ 's set ⇒ bool"
where
"cert_ok cert n T B A ⟷ (∀i < n. cert!i ∈ A ∧ cert!i ≠ T) ∧ (cert!n = B)"
definition bottom :: "'a ord ⇒ 'a ⇒ bool"
where
"bottom r B ⟷ (∀x. B ⊑⇩r x)"
locale lbv = Semilat +
fixes T :: "'a" ("⊤")
fixes B :: "'a" ("⊥")
fixes step :: "'a step_type"
assumes top: "top r ⊤"
assumes T_A: "⊤ ∈ A"
assumes bot: "bottom r ⊥"
assumes B_A: "⊥ ∈ A"
fixes merge :: "'a certificate ⇒ nat ⇒ (nat × 'a) list ⇒ 'a ⇒ 'a"
defines mrg_def: "merge cert ≡ LBVSpec.merge cert f r ⊤"
fixes wti :: "'a certificate ⇒ nat ⇒ 'a ⇒ 'a"
defines wti_def: "wti cert ≡ wtl_inst cert f r ⊤ step"
fixes wtc :: "'a certificate ⇒ nat ⇒ 'a ⇒ 'a"
defines wtc_def: "wtc cert ≡ wtl_cert cert f r ⊤ ⊥ step"
fixes wtl :: "'b list ⇒ 'a certificate ⇒ nat ⇒ 'a ⇒ 'a"
defines wtl_def: "wtl ins cert ≡ wtl_inst_list ins cert f r ⊤ ⊥ step"
lemma (in lbv) wti:
"wti c pc s = merge c pc (step pc s) (c!(pc+1))"
by (simp add: wti_def mrg_def wtl_inst_def)
lemma (in lbv) wtc:
"wtc c pc s = (if c!pc = ⊥ then wti c pc s else if s ⊑⇩r c!pc then wti c pc (c!pc) else ⊤)"
by (unfold wtc_def wti_def wtl_cert_def) rule
lemma cert_okD1 [intro?]:
"cert_ok c n T B A ⟹ pc < n ⟹ c!pc ∈ A"
by (unfold cert_ok_def) fast
lemma cert_okD2 [intro?]:
"cert_ok c n T B A ⟹ c!n = B"
by (simp add: cert_ok_def)
lemma cert_okD3 [intro?]:
"cert_ok c n T B A ⟹ B ∈ A ⟹ pc < n ⟹ c!Suc pc ∈ A"
by (drule Suc_leI) (auto simp add: le_eq_less_or_eq dest: cert_okD1 cert_okD2)
lemma cert_okD4 [intro?]:
"cert_ok c n T B A ⟹ pc < n ⟹ c!pc ≠ T"
by (simp add: cert_ok_def)
declare Let_def [simp]
subsection "more semilattice lemmas"
lemma (in lbv) sup_top [simp, elim]:
assumes x: "x ∈ A"
shows "x ⊔⇩f ⊤ = ⊤"
proof -
from top have "x ⊔⇩f ⊤ ⊑⇩r ⊤" ..
moreover from x T_A have "⊤ ⊑⇩r x ⊔⇩f ⊤" ..
ultimately show ?thesis ..
qed
lemma (in lbv) plusplussup_top [simp, elim]:
"set xs ⊆ A ⟹ xs ⨆⇘f⇙ ⊤ = ⊤"
by (induct xs) auto
lemma (in Semilat) pp_ub1':
assumes S: "snd`set S ⊆ A"
assumes y: "y ∈ A" and ab: "(a, b) ∈ set S"
shows "b ⊑⇩r map snd [(p', t') ← S . p' = a] ⨆⇘f⇙ y"
proof -
from S have "∀(x,y) ∈ set S. y ∈ A" by auto
with Semilat_axioms show ?thesis using y ab by (rule ub1')
qed
lemma (in lbv) bottom_le [simp, intro!]: "⊥ ⊑⇩r x"
by (insert bot) (simp add: bottom_def)
lemma (in lbv) le_bottom [simp]: "x ⊑⇩r ⊥ = (x = ⊥)"
by (blast intro: antisym_r)
subsection "merge"
lemma (in lbv) merge_Nil [simp]:
"merge c pc [] x = x" by (simp add: mrg_def)
lemma (in lbv) merge_Cons [simp]:
"merge c pc (l#ls) x = merge c pc ls (if fst l=pc+1 then snd l +_f x
else if snd l ⊑⇩r c!fst l then x
else ⊤)"
by (simp add: mrg_def split_beta)
lemma (in lbv) merge_Err [simp]:
"snd`set ss ⊆ A ⟹ merge c pc ss ⊤ = ⊤"
by (induct ss) auto
lemma (in lbv) merge_not_top:
"⋀x. snd`set ss ⊆ A ⟹ merge c pc ss x ≠ ⊤ ⟹
∀(pc',s') ∈ set ss. (pc' ≠ pc+1 ⟶ s' ⊑⇩r c!pc')"
(is "⋀x. ?set ss ⟹ ?merge ss x ⟹ ?P ss")
proof (induct ss)
show "?P []" by simp
next
fix x ls l
assume "?set (l#ls)" then obtain set: "snd`set ls ⊆ A" by simp
assume merge: "?merge (l#ls) x"
moreover
obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
ultimately
obtain x' where merge': "?merge ls x'" by simp
assume "⋀x. ?set ls ⟹ ?merge ls x ⟹ ?P ls" hence "?P ls" using set merge' .
moreover
from merge set
have "pc' ≠ pc+1 ⟶ s' ⊑⇩r c!pc'" by (simp split: if_split_asm)
ultimately show "?P (l#ls)" by simp
qed
lemma (in lbv) merge_def:
shows
"⋀x. x ∈ A ⟹ snd`set ss ⊆ A ⟹
merge c pc ss x =
(if ∀(pc',s') ∈ set ss. pc'≠pc+1 ⟶ s' ⊑⇩r c!pc' then
map snd [(p',t') ← ss. p'=pc+1] ⨆⇘f⇙ x
else ⊤)"
(is "⋀x. _ ⟹ _ ⟹ ?merge ss x = ?if ss x" is "⋀x. _ ⟹ _ ⟹ ?P ss x")
proof (induct ss)
fix x show "?P [] x" by simp
next
fix x assume x: "x ∈ A"
fix l::"nat × 'a" and ls
assume "snd`set (l#ls) ⊆ A"
then obtain l: "snd l ∈ A" and ls: "snd`set ls ⊆ A" by auto
assume "⋀x. x ∈ A ⟹ snd`set ls ⊆ A ⟹ ?P ls x"
hence IH: "⋀x. x ∈ A ⟹ ?P ls x" using ls by iprover
obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
hence "?merge (l#ls) x = ?merge ls
(if pc'=pc+1 then s' ⊔⇩f x else if s' ⊑⇩r c!pc' then x else ⊤)"
(is "?merge (l#ls) x = ?merge ls ?if'")
by simp
also have "… = ?if ls ?if'"
proof -
from l have "s' ∈ A" by simp
with x have "s' ⊔⇩f x ∈ A" by simp
with x T_A have "?if' ∈ A" by auto
hence "?P ls ?if'" by (rule IH) thus ?thesis by simp
qed
also have "… = ?if (l#ls) x"
proof (cases "∀(pc', s')∈set (l#ls). pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'")
case True
hence "∀(pc', s')∈set ls. pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'" by auto
moreover
from True have
"map snd [(p',t') ← ls . p'=pc+1] ⨆⇘f⇙ ?if' =
(map snd [(p',t') ← l#ls . p'=pc+1] ⨆⇘f⇙ x)"
by simp
ultimately
show ?thesis using True by simp
next
case False
moreover
from ls have "set (map snd [(p', t') ← ls . p' = Suc pc]) ⊆ A" by auto
ultimately show ?thesis by auto
qed
finally show "?P (l#ls) x" .
qed
lemma (in lbv) merge_not_top_s:
assumes x: "x ∈ A" and ss: "snd`set ss ⊆ A"
assumes m: "merge c pc ss x ≠ ⊤"
shows "merge c pc ss x = (map snd [(p',t') ← ss. p'=pc+1] ⨆⇘f⇙ x)"
proof -
from ss m have "∀(pc',s') ∈ set ss. (pc' ≠ pc+1 ⟶ s' <=_r c!pc')"
by (rule merge_not_top)
with x ss m show ?thesis by - (drule merge_def, auto split: if_split_asm)
qed
subsection "wtl-inst-list"
lemmas [iff] = not_Err_eq
lemma (in lbv) wtl_Nil [simp]: "wtl [] c pc s = s"
by (simp add: wtl_def)
lemma (in lbv) wtl_Cons [simp]:
"wtl (i#is) c pc s =
(let s' = wtc c pc s in if s' = ⊤ ∨ s = ⊤ then ⊤ else wtl is c (pc+1) s')"
by (simp add: wtl_def wtc_def)
lemma (in lbv) wtl_Cons_not_top:
"wtl (i#is) c pc s ≠ ⊤ =
(wtc c pc s ≠ ⊤ ∧ s ≠ T ∧ wtl is c (pc+1) (wtc c pc s) ≠ ⊤)"
by (auto simp del: split_paired_Ex)
lemma (in lbv) wtl_top [simp]: "wtl ls c pc ⊤ = ⊤"
by (cases ls) auto
lemma (in lbv) wtl_not_top:
"wtl ls c pc s ≠ ⊤ ⟹ s ≠ ⊤"
by (cases "s=⊤") auto
lemma (in lbv) wtl_append [simp]:
"⋀pc s. wtl (a@b) c pc s = wtl b c (pc+length a) (wtl a c pc s)"
by (induct a) auto
lemma (in lbv) wtl_take:
"wtl is c pc s ≠ ⊤ ⟹ wtl (take pc' is) c pc s ≠ ⊤"
(is "?wtl is ≠ _ ⟹ _")
proof -
assume "?wtl is ≠ ⊤"
hence "?wtl (take pc' is @ drop pc' is) ≠ ⊤" by simp
thus ?thesis by (auto dest!: wtl_not_top simp del: append_take_drop_id)
qed
lemma take_Suc:
"∀n. n < length l ⟶ take (Suc n) l = (take n l)@[l!n]" (is "?P l")
proof (induct l)
show "?P []" by simp
next
fix x xs assume IH: "?P xs"
show "?P (x#xs)"
proof (intro strip)
fix n assume "n < length (x#xs)"
with IH show "take (Suc n) (x # xs) = take n (x # xs) @ [(x # xs) ! n]"
by (cases n, auto)
qed
qed
lemma (in lbv) wtl_Suc:
assumes suc: "pc+1 < length is"
assumes wtl: "wtl (take pc is) c 0 s ≠ ⊤"
shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
proof -
from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
with suc wtl show ?thesis by (simp add: min_def)
qed
lemma (in lbv) wtl_all:
assumes all: "wtl is c 0 s ≠ ⊤" (is "?wtl is ≠ _")
assumes pc: "pc < length is"
shows "wtc c pc (wtl (take pc is) c 0 s) ≠ ⊤"
proof -
from pc have "0 < length (drop pc is)" by simp
then obtain i r where Cons: "drop pc is = i#r"
by (auto simp add: neq_Nil_conv simp del: length_drop drop_eq_Nil)
hence "i#r = drop pc is" ..
with all have take: "?wtl (take pc is@i#r) ≠ ⊤" by simp
from pc have "is!pc = drop pc is ! 0" by simp
with Cons have "is!pc = i" by simp
with take pc show ?thesis by (auto simp add: min_def split: if_split_asm)
qed
subsection "preserves-type"
lemma (in lbv) merge_pres:
assumes s0: "snd`set ss ⊆ A" and x: "x ∈ A"
shows "merge c pc ss x ∈ A"
proof -
from s0 have "set (map snd [(p', t') ← ss . p'=pc+1]) ⊆ A" by auto
with x semilat Semilat_axioms have "(map snd [(p', t') ← ss . p'=pc+1] ⨆⇘f⇙ x) ∈ A"
by (auto intro!: plusplus_closed)
with s0 x show ?thesis by (simp add: merge_def T_A)
qed
lemma pres_typeD2:
"pres_type step n A ⟹ s ∈ A ⟹ p < n ⟹ snd`set (step p s) ⊆ A"
by auto (drule pres_typeD)
lemma (in lbv) wti_pres [intro?]:
assumes pres: "pres_type step n A"
assumes cert: "c!(pc+1) ∈ A"
assumes s_pc: "s ∈ A" "pc < n"
shows "wti c pc s ∈ A"
proof -
from pres s_pc have "snd`set (step pc s) ⊆ A" by (rule pres_typeD2)
with cert show ?thesis by (simp add: wti merge_pres)
qed
lemma (in lbv) wtc_pres:
assumes "pres_type step n A"
assumes "c!pc ∈ A" and "c!(pc+1) ∈ A"
assumes "s ∈ A" and "pc < n"
shows "wtc c pc s ∈ A"
proof -
have "wti c pc s ∈ A" using assms(1,3-5) ..
moreover have "wti c pc (c!pc) ∈ A" using assms(1,3,2,5) ..
ultimately show ?thesis using T_A by (simp add: wtc)
qed
lemma (in lbv) wtl_pres:
assumes pres: "pres_type step (length is) A"
assumes cert: "cert_ok c (length is) ⊤ ⊥ A"
assumes s: "s ∈ A"
assumes all: "wtl is c 0 s ≠ ⊤"
shows "pc < length is ⟹ wtl (take pc is) c 0 s ∈ A"
(is "?len pc ⟹ ?wtl pc ∈ A")
proof (induct pc)
from s show "?wtl 0 ∈ A" by simp
next
fix n assume Suc_n: "Suc n < length is"
hence n1: "n+1 < length is" by simp
then obtain n: "n < length is" by simp
assume "n < length is ⟹ ?wtl n ∈ A"
hence "?wtl n ∈ A" using n .
from pres _ _ this n
have "wtc c n (?wtl n) ∈ A"
proof (rule wtc_pres)
from cert n show "c!n ∈ A" by (rule cert_okD1)
from cert n1 show "c!(n+1) ∈ A" by (rule cert_okD1)
qed
also
from all n have "?wtl n ≠ ⊤" by - (rule wtl_take)
with n1 have "wtc c n (?wtl n) = ?wtl (n+1)" by (rule wtl_Suc [symmetric])
finally show "?wtl (Suc n) ∈ A" by simp
qed
end
Theory LBVCorrect
section ‹Correctness of the LBV›
theory LBVCorrect
imports LBVSpec Typing_Framework
begin
locale lbvs = lbv +
fixes s⇩0 :: 'a
fixes c :: "'a list"
fixes ins :: "'b list"
fixes τs :: "'a list"
defines phi_def:
"τs ≡ map (λpc. if c!pc = ⊥ then wtl (take pc ins) c 0 s⇩0 else c!pc)
[0..<size ins]"
assumes bounded: "bounded step (size ins)"
assumes cert: "cert_ok c (size ins) ⊤ ⊥ A"
assumes pres: "pres_type step (size ins) A"
lemma (in lbvs) phi_None [intro?]:
"⟦ pc < size ins; c!pc = ⊥ ⟧ ⟹ τs!pc = wtl (take pc ins) c 0 s⇩0"
by (simp add: phi_def)
lemma (in lbvs) phi_Some [intro?]:
"⟦ pc < size ins; c!pc ≠ ⊥ ⟧ ⟹ τs!pc = c!pc"
by (simp add: phi_def)
lemma (in lbvs) phi_len [simp]: "size τs = size ins"
by (simp add: phi_def)
lemma (in lbvs) wtl_suc_pc:
assumes all: "wtl ins c 0 s⇩0 ≠ ⊤"
assumes pc: "pc+1 < size ins"
shows "wtl (take (pc+1) ins) c 0 s⇩0 ⊑⇩r τs!(pc+1)"
proof -
from all pc
have "wtc c (pc+1) (wtl (take (pc+1) ins) c 0 s⇩0) ≠ T" by (rule wtl_all)
with pc show ?thesis by (simp add: phi_def wtc split: if_split_asm)
qed
lemma (in lbvs) wtl_stable:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤"
assumes s⇩0: "s⇩0 ∈ A" and pc: "pc < size ins"
shows "stable r step τs pc"
proof (unfold stable_def, clarify)
fix pc' s' assume step: "(pc',s') ∈ set (step pc (τs ! pc))"
(is "(pc',s') ∈ set (?step pc)")
from bounded pc step have pc': "pc' < size ins" by (rule boundedD)
have tkpc: "wtl (take pc ins) c 0 s⇩0 ≠ ⊤" (is "?s⇩1 ≠ _") using wtl by (rule wtl_take)
have s⇩2: "wtl (take (pc+1) ins) c 0 s⇩0 ≠ ⊤" (is "?s⇩2 ≠ _") using wtl by (rule wtl_take)
from wtl pc have wt_s⇩1: "wtc c pc ?s⇩1 ≠ ⊤" by (rule wtl_all)
have c_Some: "∀pc t. pc < size ins ⟶ c!pc ≠ ⊥ ⟶ τs!pc = c!pc"
by (simp add: phi_def)
have c_None: "c!pc = ⊥ ⟹ τs!pc = ?s⇩1" using pc ..
from wt_s⇩1 pc c_None c_Some
have inst: "wtc c pc ?s⇩1 = wti c pc (τs!pc)"
by (simp add: wtc split: if_split_asm)
have "?s⇩1 ∈ A" using pres cert s⇩0 wtl pc by (rule wtl_pres)
with pc c_Some cert c_None
have "τs!pc ∈ A" by (cases "c!pc = ⊥") (auto dest: cert_okD1)
with pc pres
have step_in_A: "snd`set (?step pc) ⊆ A" by (auto dest: pres_typeD2)
show "s' ⊑⇩r τs!pc'"
proof (cases "pc' = pc+1")
case True
with pc' cert
have cert_in_A: "c!(pc+1) ∈ A" by (auto dest: cert_okD1)
from True pc' have pc1: "pc+1 < size ins" by simp
with tkpc have "?s⇩2 = wtc c pc ?s⇩1" by - (rule wtl_Suc)
with inst
have merge: "?s⇩2 = merge c pc (?step pc) (c!(pc+1))" by (simp add: wti)
also from s⇩2 merge have "… ≠ ⊤" (is "?merge ≠ _") by simp
with cert_in_A step_in_A
have "?merge = (map snd [(p',t') ← ?step pc. p'=pc+1] ⨆⇘f⇙ c!(pc+1))"
by (rule merge_not_top_s)
finally have "s' ⊑⇩r ?s⇩2" using step_in_A cert_in_A True step
by (auto intro: pp_ub1')
also from wtl pc1 have "?s⇩2 ⊑⇩r τs!(pc+1)" by (rule wtl_suc_pc)
also note True [symmetric]
finally show ?thesis by simp
next
case False
from wt_s⇩1 inst
have "merge c pc (?step pc) (c!(pc+1)) ≠ ⊤" by (simp add: wti)
with step_in_A have "∀(pc', s')∈set (?step pc). pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'"
by - (rule merge_not_top)
with step False have ok: "s' ⊑⇩r c!pc'" by blast
moreover from ok have "c!pc' = ⊥ ⟹ s' = ⊥" by simp
moreover from c_Some pc' have "c!pc' ≠ ⊥ ⟹ τs!pc' = c!pc'" by auto
ultimately show ?thesis by (cases "c!pc' = ⊥") auto
qed
qed
lemma (in lbvs) phi_not_top:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤" and pc: "pc < size ins"
shows "τs!pc ≠ ⊤"
proof (cases "c!pc = ⊥")
case False with pc
have "τs!pc = c!pc" ..
also from cert pc have "… ≠ ⊤" by (rule cert_okD4)
finally show ?thesis .
next
case True with pc
have "τs!pc = wtl (take pc ins) c 0 s⇩0" ..
also from wtl have "… ≠ ⊤" by (rule wtl_take)
finally show ?thesis .
qed
lemma (in lbvs) phi_in_A:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤" and s⇩0: "s⇩0 ∈ A"
shows "τs ∈ list (size ins) A"
proof -
{ fix x assume "x ∈ set τs"
then obtain xs ys where "τs = xs @ x # ys"
by (auto simp add: in_set_conv_decomp)
then obtain pc where pc: "pc < size τs" and x: "τs!pc = x"
by (simp add: that [of "size xs"] nth_append)
from pres cert wtl s⇩0 pc
have "wtl (take pc ins) c 0 s⇩0 ∈ A" by (auto intro!: wtl_pres)
moreover
from pc have "pc < size ins" by simp
with cert have "c!pc ∈ A" ..
ultimately
have "τs!pc ∈ A" using pc by (simp add: phi_def)
hence "x ∈ A" using x by simp
}
hence "set τs ⊆ A" ..
thus ?thesis by (unfold list_def) simp
qed
lemma (in lbvs) phi0:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤" and 0: "0 < size ins"
shows "s⇩0 ⊑⇩r τs!0"
proof (cases "c!0 = ⊥")
case True
with 0 have "τs!0 = wtl (take 0 ins) c 0 s⇩0" ..
moreover have "wtl (take 0 ins) c 0 s⇩0 = s⇩0" by simp
ultimately have "τs!0 = s⇩0" by simp
thus ?thesis by simp
next
case False
with 0 have "τs!0 = c!0" ..
moreover
have "wtl (take 1 ins) c 0 s⇩0 ≠ ⊤" using wtl by (rule wtl_take)
with 0 False
have "s⇩0 ⊑⇩r c!0" by (auto simp add: neq_Nil_conv wtc split: if_split_asm)
ultimately
show ?thesis by simp
qed
theorem (in lbvs) wtl_sound:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤" and s⇩0: "s⇩0 ∈ A"
shows "∃τs. wt_step r ⊤ step τs"
proof -
have "wt_step r ⊤ step τs"
proof (unfold wt_step_def, intro strip conjI)
fix pc assume "pc < size τs"
then obtain pc: "pc < size ins" by simp
with wtl show "τs!pc ≠ ⊤" by (rule phi_not_top)
from wtl s⇩0 pc show "stable r step τs pc" by (rule wtl_stable)
qed
thus ?thesis ..
qed
theorem (in lbvs) wtl_sound_strong:
assumes wtl: "wtl ins c 0 s⇩0 ≠ ⊤"
assumes s⇩0: "s⇩0 ∈ A" and ins: "0 < size ins"
shows "∃τs ∈ list (size ins) A. wt_step r ⊤ step τs ∧ s⇩0 ⊑⇩r τs!0"
proof -
have "τs ∈ list (size ins) A" using wtl s⇩0 by (rule phi_in_A)
moreover
have "wt_step r ⊤ step τs"
proof (unfold wt_step_def, intro strip conjI)
fix pc assume "pc < size τs"
then obtain pc: "pc < size ins" by simp
with wtl show "τs!pc ≠ ⊤" by (rule phi_not_top)
from wtl s⇩0 and pc show "stable r step τs pc" by (rule wtl_stable)
qed
moreover from wtl ins have "s⇩0 ⊑⇩r τs!0" by (rule phi0)
ultimately show ?thesis by fast
qed
end
Theory LBVComplete
section ‹Completeness of the LBV›
theory LBVComplete
imports LBVSpec Typing_Framework
begin
definition is_target :: "'s step_type ⇒ 's list ⇒ nat ⇒ bool" where
"is_target step τs pc' ⟷ (∃pc s'. pc' ≠ pc+1 ∧ pc < size τs ∧ (pc',s') ∈ set (step pc (τs!pc)))"
definition make_cert :: "'s step_type ⇒ 's list ⇒ 's ⇒ 's certificate" where
"make_cert step τs B = map (λpc. if is_target step τs pc then τs!pc else B) [0..<size τs] @ [B]"
lemma [code]:
"is_target step τs pc' =
list_ex (λpc. pc' ≠ pc+1 ∧ List.member (map fst (step pc (τs!pc))) pc') [0..<size τs]"
apply (simp add: list_ex_iff is_target_def member_def)
apply force
done
locale lbvc = lbv +
fixes τs :: "'a list"
fixes c :: "'a list"
defines cert_def: "c ≡ make_cert step τs ⊥"
assumes mono: "mono r step (size τs) A"
assumes pres: "pres_type step (size τs) A"
assumes τs: "∀pc < size τs. τs!pc ∈ A ∧ τs!pc ≠ ⊤"
assumes bounded: "bounded step (size τs)"
assumes B_neq_T: "⊥ ≠ ⊤"
lemma (in lbvc) cert: "cert_ok c (size τs) ⊤ ⊥ A"
proof (unfold cert_ok_def, intro strip conjI)
note [simp] = make_cert_def cert_def nth_append
show "c!size τs = ⊥" by simp
fix pc assume pc: "pc < size τs"
from pc τs B_A show "c!pc ∈ A" by simp
from pc τs B_neq_T show "c!pc ≠ ⊤" by simp
qed
lemmas [simp del] = split_paired_Ex
lemma (in lbvc) cert_target [intro?]:
"⟦ (pc',s') ∈ set (step pc (τs!pc));
pc' ≠ pc+1; pc < size τs; pc' < size τs ⟧
⟹ c!pc' = τs!pc'"
by (auto simp add: cert_def make_cert_def nth_append is_target_def)
lemma (in lbvc) cert_approx [intro?]:
"⟦ pc < size τs; c!pc ≠ ⊥ ⟧ ⟹ c!pc = τs!pc"
by (auto simp add: cert_def make_cert_def nth_append)
lemma (in lbv) le_top [simp, intro]: "x <=_r ⊤"
by (insert top) simp
lemma (in lbv) merge_mono:
assumes less: "set ss⇩2 {⊑⇘r⇙} set ss⇩1"
assumes x: "x ∈ A"
assumes ss⇩1: "snd`set ss⇩1 ⊆ A"
assumes ss⇩2: "snd`set ss⇩2 ⊆ A"
shows "merge c pc ss⇩2 x ⊑⇩r merge c pc ss⇩1 x" (is "?s⇩2 ⊑⇩r ?s⇩1")
proof-
have "?s⇩1 = ⊤ ⟹ ?thesis" by simp
moreover {
assume merge: "?s⇩1 ≠ T"
from x ss⇩1 have "?s⇩1 =
(if ∀(pc',s')∈set ss⇩1. pc' ≠ pc + 1 ⟶ s' ⊑⇩r c!pc'
then (map snd [(p', t') ← ss⇩1 . p'=pc+1]) ⨆⇘f⇙ x
else ⊤)" by (rule merge_def)
with merge obtain
app: "∀(pc',s')∈set ss⇩1. pc' ≠ pc+1 ⟶ s' ⊑⇩r c!pc'"
(is "?app ss⇩1") and
sum: "(map snd [(p',t') ← ss⇩1 . p' = pc+1] ⨆⇘f⇙ x) = ?s⇩1"
(is "?map ss⇩1 ⨆⇘f⇙ x = _" is "?sum ss⇩1 = _")
by (simp split: if_split_asm)
from app less have "?app ss⇩2" by (blast dest: trans_r lesub_step_typeD)
moreover {
from ss⇩1 have map1: "set (?map ss⇩1) ⊆ A" by auto
with x and semilat Semilat_axioms have "?sum ss⇩1 ∈ A" by (auto intro!: plusplus_closed)
with sum have "?s⇩1 ∈ A" by simp
moreover
have mapD: "⋀x ss. x ∈ set (?map ss) ⟹ ∃p. (p,x) ∈ set ss ∧ p=pc+1" by auto
from x map1 have "∀x ∈ set (?map ss⇩1). x ⊑⇩r ?sum ss⇩1" by clarify (rule pp_ub1)
with sum have "∀x ∈ set (?map ss⇩1). x ⊑⇩r ?s⇩1" by simp
with less have "∀x ∈ set (?map ss⇩2). x ⊑⇩r ?s⇩1"
by (fastforce dest!: mapD lesub_step_typeD intro: trans_r)
moreover from map1 x have "x ⊑⇩r (?sum ss⇩1)" by (rule pp_ub2)
with sum have "x ⊑⇩r ?s⇩1" by simp
moreover from ss⇩2 have "set (?map ss⇩2) ⊆ A" by auto
ultimately have "?sum ss⇩2 ⊑⇩r ?s⇩1" using x by - (rule pp_lub)
}
moreover from x ss⇩2 have "?s⇩2 =
(if ∀(pc', s')∈set ss⇩2. pc' ≠ pc + 1 ⟶ s' ⊑⇩r c!pc'
then map snd [(p', t') ← ss⇩2 . p' = pc + 1] ⨆⇘f⇙ x
else ⊤)" by (rule merge_def)
ultimately have ?thesis by simp
}
ultimately show ?thesis by (cases "?s⇩1 = ⊤") auto
qed
lemma (in lbvc) wti_mono:
assumes less: "s⇩2 ⊑⇩r s⇩1"
assumes pc: "pc < size τs" and s⇩1: "s⇩1 ∈ A" and s⇩2: "s⇩2 ∈ A"
shows "wti c pc s⇩2 ⊑⇩r wti c pc s⇩1" (is "?s⇩2' ⊑⇩r ?s⇩1'")
proof -
from mono pc s⇩2 less have "set (step pc s⇩2) {⊑⇘r⇙} set (step pc s⇩1)" by (rule monoD)
moreover from cert B_A pc have "c!Suc pc ∈ A" by (rule cert_okD3)
moreover from pres s⇩1 pc have "snd`set (step pc s⇩1) ⊆ A" by (rule pres_typeD2)
moreover from pres s⇩2 pc have "snd`set (step pc s⇩2) ⊆ A" by (rule pres_typeD2)
ultimately show ?thesis by (simp add: wti merge_mono)
qed
lemma (in lbvc) wtc_mono:
assumes less: "s⇩2 ⊑⇩r s⇩1"
assumes pc: "pc < size τs" and s⇩1: "s⇩1 ∈ A" and s⇩2: "s⇩2 ∈ A"
shows "wtc c pc s⇩2 ⊑⇩r wtc c pc s⇩1" (is "?s⇩2' ⊑⇩r ?s⇩1'")
proof (cases "c!pc = ⊥")
case True
moreover from less pc s⇩1 s⇩2 have "wti c pc s⇩2 ⊑⇩r wti c pc s⇩1" by (rule wti_mono)
ultimately show ?thesis by (simp add: wtc)
next
case False
have "?s⇩1' = ⊤ ⟹ ?thesis" by simp
moreover {
assume "?s⇩1' ≠ ⊤"
with False have c: "s⇩1 ⊑⇩r c!pc" by (simp add: wtc split: if_split_asm)
with less have "s⇩2 ⊑⇩r c!pc" ..
with False c have ?thesis by (simp add: wtc)
}
ultimately show ?thesis by (cases "?s⇩1' = ⊤") auto
qed
lemma (in lbv) top_le_conv [simp]: "⊤ ⊑⇩r x = (x = ⊤)"
by (insert semilat) (simp add: top top_le_conv)
lemma (in lbv) neq_top [simp, elim]: "⟦ x ⊑⇩r y; y ≠ ⊤ ⟧ ⟹ x ≠ ⊤"
by (cases "x = T") auto
lemma (in lbvc) stable_wti:
assumes stable: "stable r step τs pc" and pc: "pc < size τs"
shows "wti c pc (τs!pc) ≠ ⊤"
proof -
let ?step = "step pc (τs!pc)"
from stable
have less: "∀(q,s')∈set ?step. s' ⊑⇩r τs!q" by (simp add: stable_def)
from cert B_A pc have cert_suc: "c!Suc pc ∈ A" by (rule cert_okD3)
moreover from τs pc have "τs!pc ∈ A" by simp
with pres pc have stepA: "snd`set ?step ⊆ A" by - (rule pres_typeD2)
ultimately
have "merge c pc ?step (c!Suc pc) =
(if ∀(pc',s')∈set ?step. pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'
then map snd [(p',t') ← ?step.p'=pc+1] ⨆⇘f⇙ c!Suc pc
else ⊤)" unfolding mrg_def by (rule lbv.merge_def [OF lbvc.axioms(1), OF lbvc_axioms])
moreover {
fix pc' s' assume s': "(pc',s') ∈ set ?step" and suc_pc: "pc' ≠ pc+1"
with less have "s' ⊑⇩r τs!pc'" by auto
also from bounded pc s' have "pc' < size τs" by (rule boundedD)
with s' suc_pc pc have "c!pc' = τs!pc'" ..
hence "τs!pc' = c!pc'" ..
finally have "s' ⊑⇩r c!pc'" .
} hence "∀(pc',s')∈set ?step. pc'≠pc+1 ⟶ s' ⊑⇩r c!pc'" by auto
moreover from pc have "Suc pc = size τs ∨ Suc pc < size τs" by auto
hence "map snd [(p',t') ← ?step.p'=pc+1] ⨆⇘f⇙ c!Suc pc ≠ ⊤" (is "?map ⨆⇘f⇙ _ ≠ _")
proof (rule disjE)
assume pc': "Suc pc = size τs"
with cert have "c!Suc pc = ⊥" by (simp add: cert_okD2)
moreover
from pc' bounded pc
have "∀(p',t')∈set ?step. p'≠pc+1" by clarify (drule boundedD, auto)
hence "[(p',t') ← ?step. p'=pc+1] = []" by (blast intro: filter_False)
hence "?map = []" by simp
ultimately show ?thesis by (simp add: B_neq_T)
next
assume pc': "Suc pc < size τs"
from pc' τs have "τs!Suc pc ∈ A" by simp
moreover note cert_suc
moreover from stepA have "set ?map ⊆ A" by auto
moreover have "⋀s. s ∈ set ?map ⟹ ∃t. (Suc pc, t) ∈ set ?step" by auto
with less have "∀s' ∈ set ?map. s' ⊑⇩r τs!Suc pc" by auto
moreover from pc' have "c!Suc pc ⊑⇩r τs!Suc pc"
by (cases "c!Suc pc = ⊥") (auto dest: cert_approx)
ultimately have "?map ⨆⇘f⇙ c!Suc pc ⊑⇩r τs!Suc pc" by (rule pp_lub)
moreover from pc' τs have "τs!Suc pc ≠ ⊤" by simp
ultimately show ?thesis by auto
qed
ultimately have "merge c pc ?step (c!Suc pc) ≠ ⊤" by simp
thus ?thesis by (simp add: wti)
qed
lemma (in lbvc) wti_less:
assumes stable: "stable r step τs pc" and suc_pc: "Suc pc < size τs"
shows "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" (is "?wti ⊑⇩r _")
proof -
let ?step = "step pc (τs!pc)"
from stable
have less: "∀(q,s')∈set ?step. s' ⊑⇩r τs!q" by (simp add: stable_def)
from suc_pc have pc: "pc < size τs" by simp
with cert B_A have cert_suc: "c!Suc pc ∈ A" by (rule cert_okD3)
moreover from τs pc have "τs!pc ∈ A" by simp
with pres pc have stepA: "snd`set ?step ⊆ A" by - (rule pres_typeD2)
moreover from stable pc have "?wti ≠ ⊤" by (rule stable_wti)
hence "merge c pc ?step (c!Suc pc) ≠ ⊤" by (simp add: wti)
ultimately
have "merge c pc ?step (c!Suc pc) =
map snd [(p',t') ← ?step.p'=pc+1] ⨆⇘f⇙ c!Suc pc" by (rule merge_not_top_s)
hence "?wti = …" (is "_ = (?map ⨆⇘f⇙ _)" is "_ = ?sum") by (simp add: wti)
also {
from suc_pc τs have "τs!Suc pc ∈ A" by simp
moreover note cert_suc
moreover from stepA have "set ?map ⊆ A" by auto
moreover have "⋀s. s ∈ set ?map ⟹ ∃t. (Suc pc, t) ∈ set ?step" by auto
with less have "∀s' ∈ set ?map. s' ⊑⇩r τs!Suc pc" by auto
moreover from suc_pc have "c!Suc pc ⊑⇩r τs!Suc pc"
by (cases "c!Suc pc = ⊥") (auto dest: cert_approx)
ultimately have "?sum ⊑⇩r τs!Suc pc" by (rule pp_lub)
}
finally show ?thesis .
qed
lemma (in lbvc) stable_wtc:
assumes stable: "stable r step τs pc" and pc: "pc < size τs"
shows "wtc c pc (τs!pc) ≠ ⊤"
proof -
from stable pc have wti: "wti c pc (τs!pc) ≠ ⊤" by (rule stable_wti)
show ?thesis
proof (cases "c!pc = ⊥")
case True with wti show ?thesis by (simp add: wtc)
next
case False
with pc have "c!pc = τs!pc" ..
with False wti show ?thesis by (simp add: wtc)
qed
qed
lemma (in lbvc) wtc_less:
assumes stable: "stable r step τs pc" and suc_pc: "Suc pc < size τs"
shows "wtc c pc (τs!pc) ⊑⇩r τs!Suc pc" (is "?wtc ⊑⇩r _")
proof (cases "c!pc = ⊥")
case True
moreover from stable suc_pc have "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wti_less)
ultimately show ?thesis by (simp add: wtc)
next
case False
from suc_pc have pc: "pc < size τs" by simp
with stable have "?wtc ≠ ⊤" by (rule stable_wtc)
with False have "?wtc = wti c pc (c!pc)"
by (unfold wtc) (simp split: if_split_asm)
also from pc False have "c!pc = τs!pc" ..
finally have "?wtc = wti c pc (τs!pc)" .
also from stable suc_pc have "wti c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wti_less)
finally show ?thesis .
qed
lemma (in lbvc) wt_step_wtl_lemma:
assumes wt_step: "wt_step r ⊤ step τs"
shows "⋀pc s. pc+size ls = size τs ⟹ s ⊑⇩r τs!pc ⟹ s ∈ A ⟹ s≠⊤ ⟹
wtl ls c pc s ≠ ⊤"
(is "⋀pc s. _ ⟹ _ ⟹ _ ⟹ _ ⟹ ?wtl ls pc s ≠ _")
proof (induct ls)
fix pc s assume "s≠⊤" thus "?wtl [] pc s ≠ ⊤" by simp
next
fix pc s i ls
assume "⋀pc s. pc+size ls=size τs ⟹ s ⊑⇩r τs!pc ⟹ s ∈ A ⟹ s≠⊤ ⟹
?wtl ls pc s ≠ ⊤"
moreover
assume pc_l: "pc + size (i#ls) = size τs"
hence suc_pc_l: "Suc pc + size ls = size τs" by simp
ultimately
have IH: "⋀s. s ⊑⇩r τs!Suc pc ⟹ s ∈ A ⟹ s ≠ ⊤ ⟹ ?wtl ls (Suc pc) s ≠ ⊤" .
from pc_l obtain pc: "pc < size τs" by simp
with wt_step have stable: "stable r step τs pc" by (simp add: wt_step_def)
moreover note pc
ultimately have wt_τs: "wtc c pc (τs!pc) ≠ ⊤" by (rule stable_wtc)
assume s_τs: "s ⊑⇩r τs!pc"
assume sA: "s ∈ A"
from τs pc have τs_pc: "τs!pc ∈ A" by simp
from s_τs pc τs_pc sA have wt_s_τs: "wtc c pc s ⊑⇩r wtc c pc (τs!pc)" by (rule wtc_mono)
with wt_τs have wt_s: "wtc c pc s ≠ ⊤" by simp
moreover assume s: "s ≠ ⊤"
ultimately have "ls = [] ⟹ ?wtl (i#ls) pc s ≠ ⊤" by simp
moreover {
assume "ls ≠ []"
with pc_l have suc_pc: "Suc pc < size τs" by (auto simp add: neq_Nil_conv)
with stable have "wtc c pc (τs!pc) ⊑⇩r τs!Suc pc" by (rule wtc_less)
with wt_s_τs have "wtc c pc s ⊑⇩r τs!Suc pc" by (rule trans_r)
moreover from cert suc_pc have "c!pc ∈ A" "c!(pc+1) ∈ A"
by (auto simp add: cert_ok_def)
from pres this sA pc have "wtc c pc s ∈ A" by (rule wtc_pres)
ultimately have "?wtl ls (Suc pc) (wtc c pc s) ≠ ⊤" using IH wt_s by blast
with s wt_s have "?wtl (i#ls) pc s ≠ ⊤" by simp
}
ultimately show "?wtl (i#ls) pc s ≠ ⊤" by (cases ls) blast+
qed
theorem (in lbvc) wtl_complete:
assumes wt: "wt_step r ⊤ step τs"
assumes s: "s ⊑⇩r τs!0" "s ∈ A" "s ≠ ⊤" and eq: "size ins = size τs"
shows "wtl ins c 0 s ≠ ⊤"
proof -
from eq have "0+size ins = size τs" by simp
from wt this s show ?thesis by (rule wt_step_wtl_lemma)
qed
end
Theory SemiType
section ‹The Jinja Type System as a Semilattice›
theory SemiType
imports "../Common/WellForm" "../DFA/Semilattices"
begin
definition super :: "'a prog ⇒ cname ⇒ cname"
where "super P C ≡ fst (the (class P C))"
lemma superI:
"(C,D) ∈ subcls1 P ⟹ super P C = D"
by (unfold super_def) (auto dest: subcls1D)
primrec the_Class :: "ty ⇒ cname"
where
"the_Class (Class C) = C"
definition sup :: "'c prog ⇒ ty ⇒ ty ⇒ ty err"
where
"sup P T⇩1 T⇩2 ≡
if is_refT T⇩1 ∧ is_refT T⇩2 then
OK (if T⇩1 = NT then T⇩2 else
if T⇩2 = NT then T⇩1 else
(Class (exec_lub (subcls1 P) (super P) (the_Class T⇩1) (the_Class T⇩2))))
else
(if T⇩1 = T⇩2 then OK T⇩1 else Err)"
lemma sup_def':
"sup P = (λT⇩1 T⇩2.
if is_refT T⇩1 ∧ is_refT T⇩2 then
OK (if T⇩1 = NT then T⇩2 else
if T⇩2 = NT then T⇩1 else
(Class (exec_lub (subcls1 P) (super P) (the_Class T⇩1) (the_Class T⇩2))))
else
(if T⇩1 = T⇩2 then OK T⇩1 else Err))"
by (simp add: sup_def fun_eq_iff)
abbreviation
subtype :: "'c prog ⇒ ty ⇒ ty ⇒ bool"
where "subtype P ≡ widen P"
definition esl :: "'c prog ⇒ ty esl"
where
"esl P ≡ (types P, subtype P, sup P)"
lemma is_class_is_subcls:
"wf_prog m P ⟹ is_class P C = P ⊢ C ≼⇧* Object"
by (fastforce simp:is_class_def
elim: subcls_C_Object converse_rtranclE subcls1I
dest: subcls1D)
lemma subcls_antisym:
"⟦wf_prog m P; P ⊢ C ≼⇧* D; P ⊢ D ≼⇧* C⟧ ⟹ C = D"
by (auto dest: acyclic_subcls1 acyclic_impl_antisym_rtrancl antisymD)
lemma widen_antisym:
"⟦ wf_prog m P; P ⊢ T ≤ U; P ⊢ U ≤ T ⟧ ⟹ T = U"
apply (cases T)
apply (cases U)
apply auto
apply (cases U)
apply (auto elim!: subcls_antisym)
done
lemma order_widen [intro,simp]:
"wf_prog m P ⟹ order (subtype P)"
apply (unfold Semilat.order_def lesub_def)
apply (auto intro: widen_trans widen_antisym)
done
lemma NT_widen:
"P ⊢ NT ≤ T = (T = NT ∨ (∃C. T = Class C))"
by (cases T) auto
lemma Class_widen2: "P ⊢ Class C ≤ T = (∃D. T = Class D ∧ P ⊢ C ≼⇧* D)"
by (cases T) auto
lemma wf_converse_subcls1_impl_acc_subtype:
"wf ((subcls1 P)^-1) ⟹ acc (subtype P)"
apply (unfold Semilat.acc_def lesssub_def)
apply (drule_tac p = "(subcls1 P)^-1 - Id" in wf_subset)
apply blast
apply (drule wf_trancl)
apply (simp add: wf_eq_minimal)
apply clarify
apply (unfold lesub_def)
apply (rename_tac M T)
apply (case_tac "∃C. Class C ∈ M")
prefer 2
apply (case_tac T)
apply fastforce
apply fastforce
apply fastforce
apply simp
apply (rule_tac x = NT in bexI)
apply (rule allI)
apply (rule impI, erule conjE)
apply (clarsimp simp add: NT_widen)
apply simp
apply clarsimp
apply (erule_tac x = "{C. Class C : M}" in allE)
apply auto
apply (rename_tac D)
apply (rule_tac x = "Class D" in bexI)
prefer 2
apply assumption
apply clarify
apply (clarsimp simp: Class_widen2)
apply (insert rtrancl_r_diff_Id [symmetric, of "subcls1 P"])
apply simp
apply (erule rtranclE)
apply blast
apply (drule rtrancl_converseI)
apply (subgoal_tac "((subcls1 P)-Id)^-1 = ((subcls1 P)^-1 - Id)")
prefer 2
apply blast
apply simp
apply (blast intro: rtrancl_into_trancl2)
done
lemma wf_subtype_acc [intro, simp]:
"wf_prog wf_mb P ⟹ acc (subtype P)"
by (rule wf_converse_subcls1_impl_acc_subtype, rule wf_subcls1)
lemma exec_lub_refl [simp]: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)
lemma closed_err_types:
"wf_prog wf_mb P ⟹ closed (err (types P)) (lift2 (sup P))"
apply (unfold closed_def plussub_def lift2_def sup_def')
apply (frule acyclic_subcls1)
apply (frule single_valued_subcls1)
apply (auto simp: is_type_def is_refT_def is_class_is_subcls split: err.split ty.splits)
apply (blast dest!: is_lub_exec_lub is_lubD is_ubD intro!: is_ubI superI)
done
lemma sup_subtype_greater:
"⟦ wf_prog wf_mb P; is_type P t1; is_type P t2; sup P t1 t2 = OK s ⟧
⟹ subtype P t1 s ∧ subtype P t2 s"
proof -
assume wf_prog: "wf_prog wf_mb P"
{ fix c1 c2
assume is_class: "is_class P c1" "is_class P c2"
with wf_prog
obtain
"P ⊢ c1 ≼⇧* Object"
"P ⊢ c2 ≼⇧* Object"
by (blast intro: subcls_C_Object)
with single_valued_subcls1[OF wf_prog]
obtain u where
"is_lub ((subcls1 P)^* ) c1 c2 u"
by (blast dest: single_valued_has_lubs)
moreover
note acyclic_subcls1[OF wf_prog]
moreover
have "∀x y. (x, y) ∈ subcls1 P ⟶ super P x = y"
by (blast intro: superI)
ultimately
have "P ⊢ c1 ≼⇧* exec_lub (subcls1 P) (super P) c1 c2 ∧
P ⊢ c2 ≼⇧* exec_lub (subcls1 P) (super P) c1 c2"
by (simp add: exec_lub_conv) (blast dest: is_lubD is_ubD)
} note this [simp]
assume "is_type P t1" "is_type P t2" "sup P t1 t2 = OK s"
thus ?thesis
apply (unfold sup_def)
apply (cases s)
apply (auto simp add: is_refT_def split: if_split_asm)
done
qed
lemma sup_subtype_smallest:
"⟦ wf_prog wf_mb P; is_type P a; is_type P b; is_type P c;
subtype P a c; subtype P b c; sup P a b = OK d ⟧
⟹ subtype P d c"
proof -
assume wf_prog: "wf_prog wf_mb P"
{ fix c1 c2 D
assume is_class: "is_class P c1" "is_class P c2"
assume le: "P ⊢ c1 ≼⇧* D" "P ⊢ c2 ≼⇧* D"
from wf_prog is_class
obtain
"P ⊢ c1 ≼⇧* Object"
"P ⊢ c2 ≼⇧* Object"
by (blast intro: subcls_C_Object)
with single_valued_subcls1[OF wf_prog]
obtain u where
lub: "is_lub ((subcls1 P)^* ) c1 c2 u"
by (blast dest: single_valued_has_lubs)
with acyclic_subcls1[OF wf_prog]
have "exec_lub (subcls1 P) (super P) c1 c2 = u"
by (blast intro: superI exec_lub_conv)
moreover
from lub le
have "P ⊢ u ≼⇧* D"
by (simp add: is_lub_def is_ub_def)
ultimately
have "P ⊢ exec_lub (subcls1 P) (super P) c1 c2 ≼⇧* D"
by blast
} note this [intro]
have [dest!]:
"⋀C T. P ⊢ Class C ≤ T ⟹ ∃D. T=Class D ∧ P ⊢ C ≼⇧* D"
by (frule Class_widen, auto)
assume "is_type P a" "is_type P b" "is_type P c"
"subtype P a c" "subtype P b c" "sup P a b = OK d"
thus ?thesis
by (auto simp add: sup_def is_refT_def
split: if_split_asm)
qed
lemma sup_exists:
"⟦ subtype P a c; subtype P b c ⟧ ⟹ ∃T. sup P a b = OK T"
apply (unfold sup_def)
apply (cases b)
apply auto
apply (cases a)
apply auto
apply (cases a)
apply auto
done
lemma err_semilat_JType_esl:
"wf_prog wf_mb P ⟹ err_semilat (esl P)"
proof -
assume wf_prog: "wf_prog wf_mb P"
hence "order (subtype P)"..
moreover from wf_prog
have "closed (err (types P)) (lift2 (sup P))"
by (rule closed_err_types)
moreover
from wf_prog have
"(∀x∈err (types P). ∀y∈err (types P). x ⊑⇘Err.le (subtype P)⇙ x ⊔⇘lift2 (sup P)⇙ y) ∧
(∀x∈err (types P). ∀y∈err (types P). y ⊑⇘Err.le (subtype P)⇙ x ⊔⇘lift2 (sup P)⇙ y)"
by (auto simp add: lesub_def plussub_def Err.le_def lift2_def sup_subtype_greater split: err.split)
moreover from wf_prog have
"∀x∈err (types P). ∀y∈err (types P). ∀z∈err (types P).
x ⊑⇘Err.le (subtype P)⇙ z ∧ y ⊑⇘Err.le (subtype P)⇙ z ⟶ x ⊔⇘lift2 (sup P)⇙ y ⊑⇘Err.le (subtype P)⇙ z"
by (unfold lift2_def plussub_def lesub_def Err.le_def)
(auto intro: sup_subtype_smallest dest:sup_exists split: err.split)
ultimately show ?thesis by (simp add: esl_def semilat_def sl_def Err.sl_def)
qed
end
Theory JVM_SemiType
section ‹The JVM Type System as Semilattice›
theory JVM_SemiType imports SemiType begin
type_synonym ty⇩l = "ty err list"
type_synonym ty⇩s = "ty list"
type_synonym ty⇩i = "ty⇩s × ty⇩l"
type_synonym ty⇩i' = "ty⇩i option"
type_synonym ty⇩m = "ty⇩i' list"
type_synonym ty⇩P = "mname ⇒ cname ⇒ ty⇩m"
definition stk_esl :: "'c prog ⇒ nat ⇒ ty⇩s esl"
where
"stk_esl P mxs ≡ upto_esl mxs (SemiType.esl P)"
definition loc_sl :: "'c prog ⇒ nat ⇒ ty⇩l sl"
where
"loc_sl P mxl ≡ Listn.sl mxl (Err.sl (SemiType.esl P))"
definition sl :: "'c prog ⇒ nat ⇒ nat ⇒ ty⇩i' err sl"
where
"sl P mxs mxl ≡
Err.sl(Opt.esl(Product.esl (stk_esl P mxs) (Err.esl(loc_sl P mxl))))"
definition states :: "'c prog ⇒ nat ⇒ nat ⇒ ty⇩i' err set"
where "states P mxs mxl ≡ fst(sl P mxs mxl)"
definition le :: "'c prog ⇒ nat ⇒ nat ⇒ ty⇩i' err ord"
where
"le P mxs mxl ≡ fst(snd(sl P mxs mxl))"
definition sup :: "'c prog ⇒ nat ⇒ nat ⇒ ty⇩i' err binop"
where
"sup P mxs mxl ≡ snd(snd(sl P mxs mxl))"
definition sup_ty_opt :: "['c prog,ty err,ty err] ⇒ bool"
("_ ⊢ _ ≤⇩⊤ _" [71,71,71] 70)
where
"sup_ty_opt P ≡ Err.le (subtype P)"
definition sup_state :: "['c prog,ty⇩i,ty⇩i] ⇒ bool"
("_ ⊢ _ ≤⇩i _" [71,71,71] 70)
where
"sup_state P ≡ Product.le (Listn.le (subtype P)) (Listn.le (sup_ty_opt P))"
definition sup_state_opt :: "['c prog,ty⇩i',ty⇩i'] ⇒ bool"
("_ ⊢ _ ≤'' _" [71,71,71] 70)
where
"sup_state_opt P ≡ Opt.le (sup_state P)"
abbreviation
sup_loc :: "['c prog,ty⇩l,ty⇩l] ⇒ bool" ("_ ⊢ _ [≤⇩⊤] _" [71,71,71] 70)
where "P ⊢ LT [≤⇩⊤] LT' ≡ list_all2 (sup_ty_opt P) LT LT'"
notation (ASCII)
sup_ty_opt ("_ |- _ <=T _" [71,71,71] 70) and
sup_state ("_ |- _ <=i _" [71,71,71] 70) and
sup_state_opt ("_ |- _ <=' _" [71,71,71] 70) and
sup_loc ("_ |- _ [<=T] _" [71,71,71] 70)
subsection "Unfolding"
lemma JVM_states_unfold:
"states P mxs mxl ≡ err(opt((Union {list n (types P) |n. n <= mxs}) ×
list mxl (err(types P))))"
apply (unfold states_def sl_def Opt.esl_def Err.sl_def
stk_esl_def loc_sl_def Product.esl_def
Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
apply simp
done
lemma JVM_le_unfold:
"le P m n ≡
Err.le(Opt.le(Product.le(Listn.le(subtype P))(Listn.le(Err.le(subtype P)))))"
apply (unfold le_def sl_def Opt.esl_def Err.sl_def
stk_esl_def loc_sl_def Product.esl_def
Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
apply simp
done
lemma sl_def2:
"JVM_SemiType.sl P mxs mxl ≡
(states P mxs mxl, JVM_SemiType.le P mxs mxl, JVM_SemiType.sup P mxs mxl)"
by (unfold JVM_SemiType.sup_def states_def JVM_SemiType.le_def) simp
lemma JVM_le_conv:
"le P m n (OK t1) (OK t2) = P ⊢ t1 ≤' t2"
by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def
sup_state_def sup_ty_opt_def)
lemma JVM_le_Err_conv:
"le P m n = Err.le (sup_state_opt P)"
by (unfold sup_state_opt_def sup_state_def
sup_ty_opt_def JVM_le_unfold) simp
lemma err_le_unfold [iff]:
"Err.le r (OK a) (OK b) = r a b"
by (simp add: Err.le_def lesub_def)
subsection ‹Semilattice›
lemma order_sup_state_opt [intro, simp]:
"wf_prog wf_mb P ⟹ order (sup_state_opt P)"
by (unfold sup_state_opt_def sup_state_def sup_ty_opt_def) blast
lemma semilat_JVM [intro?]:
"wf_prog wf_mb P ⟹ semilat (JVM_SemiType.sl P mxs mxl)"
apply (unfold JVM_SemiType.sl_def stk_esl_def loc_sl_def)
apply (blast intro: err_semilat_Product_esl err_semilat_upto_esl
Listn_sl err_semilat_JType_esl)
done
lemma acc_JVM [intro]:
"wf_prog wf_mb P ⟹ acc (JVM_SemiType.le P mxs mxl)"
by (unfold JVM_le_unfold) blast
subsection ‹Widening with ‹⊤››
lemma subtype_refl[iff]: "subtype P t t" by (simp add: fun_of_def)
lemma sup_ty_opt_refl [iff]: "P ⊢ T ≤⇩⊤ T"
apply (unfold sup_ty_opt_def)
apply (fold lesub_def)
apply (rule le_err_refl)
apply (simp add: lesub_def)
done
lemma Err_any_conv [iff]: "P ⊢ Err ≤⇩⊤ T = (T = Err)"
by (unfold sup_ty_opt_def) (rule Err_le_conv [simplified lesub_def])
lemma any_Err [iff]: "P ⊢ T ≤⇩⊤ Err"
by (unfold sup_ty_opt_def) (rule le_Err [simplified lesub_def])
lemma OK_OK_conv [iff]:
"P ⊢ OK T ≤⇩⊤ OK T' = P ⊢ T ≤ T'"
by (simp add: sup_ty_opt_def fun_of_def)
lemma any_OK_conv [iff]:
"P ⊢ X ≤⇩⊤ OK T' = (∃T. X = OK T ∧ P ⊢ T ≤ T')"
apply (unfold sup_ty_opt_def)
apply (rule le_OK_conv [simplified lesub_def])
done
lemma OK_any_conv:
"P ⊢ OK T ≤⇩⊤ X = (X = Err ∨ (∃T'. X = OK T' ∧ P ⊢ T ≤ T'))"
apply (unfold sup_ty_opt_def)
apply (rule OK_le_conv [simplified lesub_def])
done
lemma sup_ty_opt_trans [intro?, trans]:
"⟦P ⊢ a ≤⇩⊤ b; P ⊢ b ≤⇩⊤ c⟧ ⟹ P ⊢ a ≤⇩⊤ c"
by (auto intro: widen_trans
simp add: sup_ty_opt_def Err.le_def lesub_def fun_of_def
split: err.splits)
subsection "Stack and Registers"
lemma stk_convert:
"P ⊢ ST [≤] ST' = Listn.le (subtype P) ST ST'"
by (simp add: Listn.le_def lesub_def)
lemma sup_loc_refl [iff]: "P ⊢ LT [≤⇩⊤] LT"
by (rule list_all2_refl) simp
lemmas sup_loc_Cons1 [iff] = list_all2_Cons1 [of "sup_ty_opt P"] for P
lemma sup_loc_def:
"P ⊢ LT [≤⇩⊤] LT' ≡ Listn.le (sup_ty_opt P) LT LT'"
by (simp add: Listn.le_def lesub_def)
lemma sup_loc_widens_conv [iff]:
"P ⊢ map OK Ts [≤⇩⊤] map OK Ts' = P ⊢ Ts [≤] Ts'"
by (simp add: list_all2_map1 list_all2_map2)
lemma sup_loc_trans [intro?, trans]:
"⟦P ⊢ a [≤⇩⊤] b; P ⊢ b [≤⇩⊤] c⟧ ⟹ P ⊢ a [≤⇩⊤] c"
by (rule list_all2_trans, rule sup_ty_opt_trans)
subsection "State Type"
lemma sup_state_conv [iff]:
"P ⊢ (ST,LT) ≤⇩i (ST',LT') = (P ⊢ ST [≤] ST' ∧ P ⊢ LT [≤⇩⊤] LT')"
by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_def)
lemma sup_state_conv2:
"P ⊢ s1 ≤⇩i s2 = (P ⊢ fst s1 [≤] fst s2 ∧ P ⊢ snd s1 [≤⇩⊤] snd s2)"
by (cases s1, cases s2) simp
lemma sup_state_refl [iff]: "P ⊢ s ≤⇩i s"
by (auto simp add: sup_state_conv2)
lemma sup_state_trans [intro?, trans]:
"⟦P ⊢ a ≤⇩i b; P ⊢ b ≤⇩i c⟧ ⟹ P ⊢ a ≤⇩i c"
by (auto intro: sup_loc_trans widens_trans simp add: sup_state_conv2)
lemma sup_state_opt_None_any [iff]:
"P ⊢ None ≤' s"
by (simp add: sup_state_opt_def Opt.le_def)
lemma sup_state_opt_any_None [iff]:
"P ⊢ s ≤' None = (s = None)"
by (simp add: sup_state_opt_def Opt.le_def)
lemma sup_state_opt_Some_Some [iff]:
"P ⊢ Some a ≤' Some b = P ⊢ a ≤⇩i b"
by (simp add: sup_state_opt_def Opt.le_def lesub_def)
lemma sup_state_opt_any_Some:
"P ⊢ (Some s) ≤' X = (∃s'. X = Some s' ∧ P ⊢ s ≤⇩i s')"
by (simp add: sup_state_opt_def Opt.le_def lesub_def)
lemma sup_state_opt_refl [iff]: "P ⊢ s ≤' s"
by (simp add: sup_state_opt_def Opt.le_def lesub_def)
lemma sup_state_opt_trans [intro?, trans]:
"⟦P ⊢ a ≤' b; P ⊢ b ≤' c⟧ ⟹ P ⊢ a ≤' c"
apply (unfold sup_state_opt_def Opt.le_def lesub_def)
apply (simp del: split_paired_All)
apply (rule sup_state_trans, assumption+)
done
end
Theory Effect
section ‹Effect of Instructions on the State Type›
theory Effect
imports JVM_SemiType "../JVM/JVMExceptions"
begin
locale prog =
fixes P :: "'a prog"
locale jvm_method = prog +
fixes mxs :: nat
fixes mxl⇩0 :: nat
fixes Ts :: "ty list"
fixes T⇩r :: ty
fixes "is" :: "instr list"
fixes xt :: ex_table
fixes mxl :: nat
defines mxl_def: "mxl ≡ 1+size Ts+mxl⇩0"
text ‹Program counter of successor instructions:›
primrec succs :: "instr ⇒ ty⇩i ⇒ pc ⇒ pc list" where
"succs (Load idx) τ pc = [pc+1]"
| "succs (Store idx) τ pc = [pc+1]"
| "succs (Push v) τ pc = [pc+1]"
| "succs (Getfield F C) τ pc = [pc+1]"
| "succs (Putfield F C) τ pc = [pc+1]"
| "succs (New C) τ pc = [pc+1]"
| "succs (Checkcast C) τ pc = [pc+1]"
| "succs Pop τ pc = [pc+1]"
| "succs IAdd τ pc = [pc+1]"
| "succs CmpEq τ pc = [pc+1]"
| succs_IfFalse:
"succs (IfFalse b) τ pc = [pc+1, nat (int pc + b)]"
| succs_Goto:
"succs (Goto b) τ pc = [nat (int pc + b)]"
| succs_Return:
"succs Return τ pc = []"
| succs_Invoke:
"succs (Invoke M n) τ pc = (if (fst τ)!n = NT then [] else [pc+1])"
| succs_Throw:
"succs Throw τ pc = []"
text "Effect of instruction on the state type:"
fun the_class:: "ty ⇒ cname" where
"the_class (Class C) = C"
fun eff⇩i :: "instr × 'm prog × ty⇩i ⇒ ty⇩i" where
eff⇩i_Load:
"eff⇩i (Load n, P, (ST, LT)) = (ok_val (LT ! n) # ST, LT)"
| eff⇩i_Store:
"eff⇩i (Store n, P, (T#ST, LT)) = (ST, LT[n:= OK T])"
| eff⇩i_Push:
"eff⇩i (Push v, P, (ST, LT)) = (the (typeof v) # ST, LT)"
| eff⇩i_Getfield:
"eff⇩i (Getfield F C, P, (T#ST, LT)) = (snd (field P C F) # ST, LT)"
| eff⇩i_Putfield:
"eff⇩i (Putfield F C, P, (T⇩1#T⇩2#ST, LT)) = (ST,LT)"
| eff⇩i_New:
"eff⇩i (New C, P, (ST,LT)) = (Class C # ST, LT)"
| eff⇩i_Checkcast:
"eff⇩i (Checkcast C, P, (T#ST,LT)) = (Class C # ST,LT)"
| eff⇩i_Pop:
"eff⇩i (Pop, P, (T#ST,LT)) = (ST,LT)"
| eff⇩i_IAdd:
"eff⇩i (IAdd, P,(T⇩1#T⇩2#ST,LT)) = (Integer#ST,LT)"
| eff⇩i_CmpEq:
"eff⇩i (CmpEq, P, (T⇩1#T⇩2#ST,LT)) = (Boolean#ST,LT)"
| eff⇩i_IfFalse:
"eff⇩i (IfFalse b, P, (T⇩1#ST,LT)) = (ST,LT)"
| eff⇩i_Invoke:
"eff⇩i (Invoke M n, P, (ST,LT)) =
(let C = the_class (ST!n); (D,Ts,T⇩r,b) = method P C M
in (T⇩r # drop (n+1) ST, LT))"
| eff⇩i_Goto:
"eff⇩i (Goto n, P, s) = s"
fun is_relevant_class :: "instr ⇒ 'm prog ⇒ cname ⇒ bool" where
rel_Getfield:
"is_relevant_class (Getfield F D) = (λP C. P ⊢ NullPointer ≼⇧* C)"
| rel_Putfield:
"is_relevant_class (Putfield F D) = (λP C. P ⊢ NullPointer ≼⇧* C)"
| rel_Checcast:
"is_relevant_class (Checkcast D) = (λP C. P ⊢ ClassCast ≼⇧* C)"
| rel_New:
"is_relevant_class (New D) = (λP C. P ⊢ OutOfMemory ≼⇧* C)"
| rel_Throw:
"is_relevant_class Throw = (λP C. True)"
| rel_Invoke:
"is_relevant_class (Invoke M n) = (λP C. True)"
| rel_default:
"is_relevant_class i = (λP C. False)"
definition is_relevant_entry :: "'m prog ⇒ instr ⇒ pc ⇒ ex_entry ⇒ bool" where
"is_relevant_entry P i pc e ⟷ (let (f,t,C,h,d) = e in is_relevant_class i P C ∧ pc ∈ {f..<t})"
definition relevant_entries :: "'m prog ⇒ instr ⇒ pc ⇒ ex_table ⇒ ex_table" where
"relevant_entries P i pc = filter (is_relevant_entry P i pc)"
definition xcpt_eff :: "instr ⇒ 'm prog ⇒ pc ⇒ ty⇩i
⇒ ex_table ⇒ (pc × ty⇩i') list" where
"xcpt_eff i P pc τ et = (let (ST,LT) = τ in
map (λ(f,t,C,h,d). (h, Some (Class C#drop (size ST - d) ST, LT))) (relevant_entries P i pc et))"
definition norm_eff :: "instr ⇒ 'm prog ⇒ nat ⇒ ty⇩i ⇒ (pc × ty⇩i') list" where
"norm_eff i P pc τ = map (λpc'. (pc',Some (eff⇩i (i,P,τ)))) (succs i τ pc)"
definition eff :: "instr ⇒ 'm prog ⇒ pc ⇒ ex_table ⇒ ty⇩i' ⇒ (pc × ty⇩i') list" where
"eff i P pc et t = (case t of
None ⇒ []
| Some τ ⇒ (norm_eff i P pc τ) @ (xcpt_eff i P pc τ et))"
lemma eff_None:
"eff i P pc xt None = []"
by (simp add: eff_def)
lemma eff_Some:
"eff i P pc xt (Some τ) = norm_eff i P pc τ @ xcpt_eff i P pc τ xt"
by (simp add: eff_def)
text "Conditions under which eff is applicable:"
fun app⇩i :: "instr × 'm prog × pc × nat × ty × ty⇩i ⇒ bool" where
app⇩i_Load:
"app⇩i (Load n, P, pc, mxs, T⇩r, (ST,LT)) =
(n < length LT ∧ LT ! n ≠ Err ∧ length ST < mxs)"
| app⇩i_Store:
"app⇩i (Store n, P, pc, mxs, T⇩r, (T#ST, LT)) =
(n < length LT)"
| app⇩i_Push:
"app⇩i (Push v, P, pc, mxs, T⇩r, (ST,LT)) =
(length ST < mxs ∧ typeof v ≠ None)"
| app⇩i_Getfield:
"app⇩i (Getfield F C, P, pc, mxs, T⇩r, (T#ST, LT)) =
(∃T⇩f. P ⊢ C sees F:T⇩f in C ∧ P ⊢ T ≤ Class C)"
| app⇩i_Putfield:
"app⇩i (Putfield F C, P, pc, mxs, T⇩r, (T⇩1#T⇩2#ST, LT)) =
(∃T⇩f. P ⊢ C sees F:T⇩f in C ∧ P ⊢ T⇩2 ≤ (Class C) ∧ P ⊢ T⇩1 ≤ T⇩f)"
| app⇩i_New:
"app⇩i (New C, P, pc, mxs, T⇩r, (ST,LT)) =
(is_class P C ∧ length ST < mxs)"
| app⇩i_Checkcast:
"app⇩i (Checkcast C, P, pc, mxs, T⇩r, (T#ST,LT)) =
(is_class P C ∧ is_refT T)"
| app⇩i_Pop:
"app⇩i (Pop, P, pc, mxs, T⇩r, (T#ST,LT)) =
True"
| app⇩i_IAdd:
"app⇩i (IAdd, P, pc, mxs, T⇩r, (T⇩1#T⇩2#ST,LT)) = (T⇩1 = T⇩2 ∧ T⇩1 = Integer)"
| app⇩i_CmpEq:
"app⇩i (CmpEq, P, pc, mxs, T⇩r, (T⇩1#T⇩2#ST,LT)) =
(T⇩1 = T⇩2 ∨ is_refT T⇩1 ∧ is_refT T⇩2)"
| app⇩i_IfFalse:
"app⇩i (IfFalse b, P, pc, mxs, T⇩r, (Boolean#ST,LT)) =
(0 ≤ int pc + b)"
| app⇩i_Goto:
"app⇩i (Goto b, P, pc, mxs, T⇩r, s) =
(0 ≤ int pc + b)"
| app⇩i_Return:
"app⇩i (Return, P, pc, mxs, T⇩r, (T#ST,LT)) =
(P ⊢ T ≤ T⇩r)"
| app⇩i_Throw:
"app⇩i (Throw, P, pc, mxs, T⇩r, (T#ST,LT)) =
is_refT T"
| app⇩i_Invoke:
"app⇩i (Invoke M n, P, pc, mxs, T⇩r, (ST,LT)) =
(n < length ST ∧
(ST!n ≠ NT ⟶
(∃C D Ts T m. ST!n = Class C ∧ P ⊢ C sees M:Ts → T = m in D ∧
P ⊢ rev (take n ST) [≤] Ts)))"
| app⇩i_default:
"app⇩i (i,P, pc,mxs,T⇩r,s) = False"
definition xcpt_app :: "instr ⇒ 'm prog ⇒ pc ⇒ nat ⇒ ex_table ⇒ ty⇩i ⇒ bool" where
"xcpt_app i P pc mxs xt τ ⟷ (∀(f,t,C,h,d) ∈ set (relevant_entries P i pc xt). is_class P C ∧ d ≤ size (fst τ) ∧ d < mxs)"
definition app :: "instr ⇒ 'm prog ⇒ nat ⇒ ty ⇒ nat ⇒ nat ⇒ ex_table ⇒ ty⇩i' ⇒ bool" where
"app i P mxs T⇩r pc mpc xt t = (case t of None ⇒ True | Some τ ⇒
app⇩i (i,P,pc,mxs,T⇩r,τ) ∧ xcpt_app i P pc mxs xt τ ∧
(∀(pc',τ') ∈ set (eff i P pc xt t). pc' < mpc))"
lemma app_Some:
"app i P mxs T⇩r pc mpc xt (Some τ) =
(app⇩i (i,P,pc,mxs,T⇩r,τ) ∧ xcpt_app i P pc mxs xt τ ∧
(∀(pc',s') ∈ set (eff i P pc xt (Some τ)). pc' < mpc))"
by (simp add: app_def)
locale eff = jvm_method +
fixes eff⇩i and app⇩i and eff and app
fixes norm_eff and xcpt_app and xcpt_eff
fixes mpc
defines "mpc ≡ size is"
defines "eff⇩i i τ ≡ Effect.eff⇩i (i,P,τ)"
notes eff⇩i_simps [simp] = Effect.eff⇩i.simps [where P = P, folded eff⇩i_def]
defines "app⇩i i pc τ ≡ Effect.app⇩i (i, P, pc, mxs, T⇩r, τ)"
notes app⇩i_simps [simp] = Effect.app⇩i.simps [where P=P and mxs=mxs and T⇩r=T⇩r, folded app⇩i_def]
defines "xcpt_eff i pc τ ≡ Effect.xcpt_eff i P pc τ xt"
notes xcpt_eff = Effect.xcpt_eff_def [of _ P _ _ xt, folded xcpt_eff_def]
defines "norm_eff i pc τ ≡ Effect.norm_eff i P pc τ"
notes norm_eff = Effect.norm_eff_def [of _ P, folded norm_eff_def eff⇩i_def]
defines "eff i pc ≡ Effect.eff i P pc xt"
notes eff = Effect.eff_def [of _ P _ xt, folded eff_def norm_eff_def xcpt_eff_def]
defines "xcpt_app i pc τ ≡ Effect.xcpt_app i P pc mxs xt τ"
notes xcpt_app = Effect.xcpt_app_def [of _ P _ mxs xt, folded xcpt_app_def]
defines "app i pc ≡ Effect.app i P mxs T⇩r pc mpc xt"
notes app = Effect.app_def [of _ P mxs T⇩r _ mpc xt, folded app_def xcpt_app_def app⇩i_def eff_def]
lemma length_cases2:
assumes "⋀LT. P ([],LT)"
assumes "⋀l ST LT. P (l#ST,LT)"
shows "P s"
by (cases s, cases "fst s") (auto intro!: assms)
lemma length_cases3:
assumes "⋀LT. P ([],LT)"
assumes "⋀l LT. P ([l],LT)"
assumes "⋀l ST LT. P (l#ST,LT)"
shows "P s"
proof -
obtain xs LT where s: "s = (xs,LT)" by (cases s)
show ?thesis
proof (cases xs)
case Nil with assms s show ?thesis by simp
next
fix l xs' assume "xs = l#xs'"
with assms s show ?thesis by simp
qed
qed
lemma length_cases4:
assumes "⋀LT. P ([],LT)"
assumes "⋀l LT. P ([l],LT)"
assumes "⋀l l' LT. P ([l,l'],LT)"
assumes "⋀l l' ST LT. P (l#l'#ST,LT)"
shows "P s"
proof -
obtain xs LT where s: "s = (xs,LT)" by (cases s)
show ?thesis
proof (cases xs)
case Nil with assms s show ?thesis by simp
next
fix l xs' assume xs: "xs = l#xs'"
thus ?thesis
proof (cases xs')
case Nil with assms s xs show ?thesis by simp
next
fix l' ST assume "xs' = l'#ST"
with assms s xs show ?thesis by simp
qed
qed
qed
text ‹
\medskip
simp rules for @{term app}
›
lemma appNone[simp]: "app i P mxs T⇩r pc mpc et None = True"
by (simp add: app_def)
lemma appLoad[simp]:
"app⇩i (Load idx, P, T⇩r, mxs, pc, s) = (∃ST LT. s = (ST,LT) ∧ idx < length LT ∧ LT!idx ≠ Err ∧ length ST < mxs)"
by (cases s, simp)
lemma appStore[simp]:
"app⇩i (Store idx,P,pc,mxs,T⇩r,s) = (∃ts ST LT. s = (ts#ST,LT) ∧ idx < length LT)"
by (rule length_cases2, auto)
lemma appPush[simp]:
"app⇩i (Push v,P,pc,mxs,T⇩r,s) =
(∃ST LT. s = (ST,LT) ∧ length ST < mxs ∧ typeof v ≠ None)"
by (cases s, simp)
lemma appGetField[simp]:
"app⇩i (Getfield F C,P,pc,mxs,T⇩r,s) =
(∃ oT vT ST LT. s = (oT#ST, LT) ∧
P ⊢ C sees F:vT in C ∧ P ⊢ oT ≤ (Class C))"
by (rule length_cases2 [of _ s]) auto
lemma appPutField[simp]:
"app⇩i (Putfield F C,P,pc,mxs,T⇩r,s) =
(∃ vT vT' oT ST LT. s = (vT#oT#ST, LT) ∧
P ⊢ C sees F:vT' in C ∧ P ⊢ oT ≤ (Class C) ∧ P ⊢ vT ≤ vT')"
by (rule length_cases4 [of _ s], auto)
lemma appNew[simp]:
"app⇩i (New C,P,pc,mxs,T⇩r,s) =
(∃ST LT. s=(ST,LT) ∧ is_class P C ∧ length ST < mxs)"
by (cases s, simp)
lemma appCheckcast[simp]:
"app⇩i (Checkcast C,P,pc,mxs,T⇩r,s) =
(∃T ST LT. s = (T#ST,LT) ∧ is_class P C ∧ is_refT T)"
by (cases s, cases "fst s", simp add: app_def) (cases "hd (fst s)", auto)
lemma app⇩iPop[simp]:
"app⇩i (Pop,P,pc,mxs,T⇩r,s) = (∃ts ST LT. s = (ts#ST,LT))"
by (rule length_cases2, auto)
lemma appIAdd[simp]:
"app⇩i (IAdd,P,pc,mxs,T⇩r,s) = (∃ST LT. s = (Integer#Integer#ST,LT))"
proof -
obtain ST LT where [simp]: "s = (ST,LT)" by (cases s)
have "ST = [] ∨ (∃T. ST = [T]) ∨ (∃T⇩1 T⇩2 ST'. ST = T⇩1#T⇩2#ST')"
by (cases ST, auto, case_tac list, auto)
moreover
{ assume "ST = []" hence ?thesis by simp }
moreover
{ fix T assume "ST = [T]" hence ?thesis by (cases T, auto) }
moreover
{ fix T⇩1 T⇩2 ST' assume "ST = T⇩1#T⇩2#ST'"
hence ?thesis by (cases T⇩1, auto)
}
ultimately show ?thesis by blast
qed
lemma appIfFalse [simp]:
"app⇩i (IfFalse b,P,pc,mxs,T⇩r,s) =
(∃ST LT. s = (Boolean#ST,LT) ∧ 0 ≤ int pc + b)"
apply (rule length_cases2)
apply simp
apply (case_tac l)
apply auto
done
lemma appCmpEq[simp]:
"app⇩i (CmpEq,P,pc,mxs,T⇩r,s) =
(∃T⇩1 T⇩2 ST LT. s = (T⇩1#T⇩2#ST,LT) ∧ (¬is_refT T⇩1 ∧ T⇩2 = T⇩1 ∨ is_refT T⇩1 ∧ is_refT T⇩2))"
by (rule length_cases4, auto)
lemma appReturn[simp]:
"app⇩i (Return,P,pc,mxs,T⇩r,s) = (∃T ST LT. s = (T#ST,LT) ∧ P ⊢ T ≤ T⇩r)"
by (rule length_cases2, auto)
lemma appThrow[simp]:
"app⇩i (Throw,P,pc,mxs,T⇩r,s) = (∃T ST LT. s=(T#ST,LT) ∧ is_refT T)"
by (rule length_cases2, auto)
lemma effNone:
"(pc', s') ∈ set (eff i P pc et None) ⟹ s' = None"
by (auto simp add: eff_def xcpt_eff_def norm_eff_def)
text ‹some helpers to make the specification directly executable:›
lemma relevant_entries_append [simp]:
"relevant_entries P i pc (xt @ xt') = relevant_entries P i pc xt @ relevant_entries P i pc xt'"
by (unfold relevant_entries_def) simp
lemma xcpt_app_append [iff]:
"xcpt_app i P pc mxs (xt@xt') τ = (xcpt_app i P pc mxs xt τ ∧ xcpt_app i P pc mxs xt' τ)"
by (unfold xcpt_app_def) fastforce
lemma xcpt_eff_append [simp]:
"xcpt_eff i P pc τ (xt@xt') = xcpt_eff i P pc τ xt @ xcpt_eff i P pc τ xt'"
by (unfold xcpt_eff_def, cases τ) simp
lemma app_append [simp]:
"app i P pc T mxs mpc (xt@xt') τ = (app i P pc T mxs mpc xt τ ∧ app i P pc T mxs mpc xt' τ)"
by (unfold app_def eff_def) auto
end
Theory EffectMono
section ‹Monotonicity of eff and app›
theory EffectMono imports Effect begin
declare not_Err_eq [iff]
lemma app⇩i_mono:
assumes wf: "wf_prog p P"
assumes less: "P ⊢ τ ≤⇩i τ'"
shows "app⇩i (i,P,mxs,mpc,rT,τ') ⟹ app⇩i (i,P,mxs,mpc,rT,τ)"
proof -
assume app: "app⇩i (i,P,mxs,mpc,rT,τ')"
obtain ST LT ST' LT' where
[simp]: "τ = (ST,LT)" and
[simp]: "τ' = (ST',LT')"
by (cases τ, cases τ')
from less have [simp]: "size ST = size ST'" and [simp]: "size LT = size LT'"
by (auto dest: list_all2_lengthD)
note [iff] = list_all2_Cons2 widen_Class
note [simp] = fun_of_def
from app less show "app⇩i (i,P,mxs,mpc,rT,τ)"
proof (cases i)
case Load
with app less show ?thesis by (auto dest!: list_all2_nthD)
next
case (Invoke M n)
with app have n: "n < size ST'" by simp
{ assume "ST!n = NT" hence ?thesis using n app Invoke by simp }
moreover {
assume "ST'!n = NT"
moreover with n less have "ST!n = NT"
by (auto dest: list_all2_nthD)
ultimately have ?thesis using n app Invoke by simp
}
moreover {
assume ST: "ST!n ≠ NT" and ST': "ST'!n ≠ NT"
from ST' app Invoke obtain D Ts T m C' where
D: "ST' ! n = Class D" and
Ts: "P ⊢ rev (take n ST') [≤] Ts" and
D_M: "P ⊢ D sees M: Ts→T = m in C'"
by auto
from n D less have "P ⊢ ST!n ≤ ST'!n"
by (fastforce dest: list_all2_nthD2)
with D ST obtain D' where
D': "ST!n = Class D'" and DsubC: "P ⊢ D' ≼⇧* D" by auto
from wf D_M DsubC obtain Ts' T' m' C'' where
D'_M: "P ⊢ D' sees M: Ts'→T' = m' in C''" and
Ts': "P ⊢ Ts [≤] Ts'"
by (blast dest: sees_method_mono)
from less have "P ⊢ rev (take n ST) [≤] rev (take n ST')" by simp
also note Ts also note Ts'
finally have "P ⊢ rev (take n ST) [≤] Ts'" .
with D'_M D' app less Invoke have ?thesis by fastforce
}
ultimately show ?thesis by blast
next
case Getfield
with app less show ?thesis by (fastforce intro: rtrancl_trans)
next
case (Putfield F C)
with app less show ?thesis by (fastforce intro: widen_trans rtrancl_trans)
next
case Return
with app less show ?thesis by (fastforce intro: widen_trans)
qed (auto elim!: refTE not_refTE)
qed
lemma succs_mono:
assumes wf: "wf_prog p P" and app⇩i: "app⇩i (i,P,mxs,mpc,rT,τ')"
shows "P ⊢ τ ≤⇩i τ' ⟹ set (succs i τ pc) ⊆ set (succs i τ' pc)"
proof (cases i)
case (Invoke M n)
obtain ST LT ST' LT' where
[simp]: "τ = (ST,LT)" and [simp]: "τ' = (ST',LT')" by (cases τ, cases τ')
assume "P ⊢ τ ≤⇩i τ'"
moreover
with app⇩i Invoke have "n < size ST" by (auto dest: list_all2_lengthD)
ultimately
have "P ⊢ ST!n ≤ ST'!n" by (auto simp add: fun_of_def dest: list_all2_nthD)
with Invoke show ?thesis by auto
qed auto
lemma app_mono:
assumes wf: "wf_prog p P"
assumes less': "P ⊢ τ ≤' τ'"
shows "app i P m rT pc mpc xt τ' ⟹ app i P m rT pc mpc xt τ"
proof (cases τ)
case None thus ?thesis by simp
next
case (Some τ⇩1)
moreover
with less' obtain τ⇩2 where τ⇩2: "τ' = Some τ⇩2" by (cases τ') auto
ultimately have less: "P ⊢ τ⇩1 ≤⇩i τ⇩2" using less' by simp
assume "app i P m rT pc mpc xt τ'"
with Some τ⇩2 obtain
app⇩i: "app⇩i (i, P, pc, m, rT, τ⇩2)" and
xcpt: "xcpt_app i P pc m xt τ⇩2" and
succs: "∀(pc',s')∈set (eff i P pc xt (Some τ⇩2)). pc' < mpc"
by (auto simp add: app_def)
from wf less app⇩i have "app⇩i (i, P, pc, m, rT, τ⇩1)" by (rule app⇩i_mono)
moreover
from less have "size (fst τ⇩1) = size (fst τ⇩2)"
by (cases τ⇩1, cases τ⇩2) (auto dest: list_all2_lengthD)
with xcpt have "xcpt_app i P pc m xt τ⇩1" by (simp add: xcpt_app_def)
moreover
from wf app⇩i less have "∀pc. set (succs i τ⇩1 pc) ⊆ set (succs i τ⇩2 pc)"
by (blast dest: succs_mono)
with succs
have "∀(pc',s')∈set (eff i P pc xt (Some τ⇩1)). pc' < mpc"
by (cases τ⇩1, cases τ⇩2)
(auto simp add: eff_def norm_eff_def xcpt_eff_def dest: bspec)
ultimately
show ?thesis using Some by (simp add: app_def)
qed
lemma eff⇩i_mono:
assumes wf: "wf_prog p P"
assumes less: "P ⊢ τ ≤⇩i τ'"
assumes app⇩i: "app i P m rT pc mpc xt (Some τ')"
assumes succs: "succs i τ pc ≠ []" "succs i τ' pc ≠ []"
shows "P ⊢ eff⇩i (i,P,τ) ≤⇩i eff⇩i (i,P,τ')"
proof -
obtain ST LT ST' LT' where
[simp]: "τ = (ST,LT)" and
[simp]: "τ' = (ST',LT')"
by (cases τ, cases τ')
note [simp] = eff_def app_def fun_of_def
from less have "P ⊢ (Some τ) ≤' (Some τ')" by simp
from wf this app⇩i
have app: "app i P m rT pc mpc xt (Some τ)" by (rule app_mono)
from less app app⇩i show ?thesis
proof (cases i)
case Throw with succs have False by simp
thus ?thesis ..
next
case Return with succs have False by simp
thus ?thesis ..
next
case (Load i)
from Load app obtain y where
y: "i < size LT" "LT!i = OK y" by clarsimp
from Load app⇩i obtain y' where
y': "i < size LT'" "LT'!i = OK y'" by clarsimp
from less have "P ⊢ LT [≤⇩⊤] LT'" by simp
with y y' have "P ⊢ y ≤ y'" by (auto dest: list_all2_nthD)
with Load less y y' app app⇩i
show ?thesis by auto
next
case Store with less app app⇩i
show ?thesis by (auto simp add: list_all2_update_cong)
next
case (Invoke M n)
with app⇩i have n: "n < size ST'" by simp
from less have [simp]: "size ST = size ST'"
by (auto dest: list_all2_lengthD)
from Invoke succs have ST: "ST!n ≠ NT" and ST': "ST'!n ≠ NT"
by (auto split: if_split_asm)
from ST' app⇩i Invoke obtain D Ts T m C' where
D: "ST' ! n = Class D" and
D_M: "P ⊢ D sees M: Ts→T = m in C'"
by auto
from n D less have "P ⊢ ST!n ≤ ST'!n"
by (fastforce dest: list_all2_nthD2)
with D ST obtain D' where
D': "ST ! n = Class D'" and DsubC: "P ⊢ D' ≼⇧* D"
by (auto simp: widen_Class)
from wf D_M DsubC obtain Ts' T' m' C'' where
D'_M: "P ⊢ D' sees M: Ts'→T' = m' in C''" and
Ts': "P ⊢ T' ≤ T"
by (blast dest: sees_method_mono)
with Invoke n D D' D_M less
show ?thesis by (auto intro: list_all2_dropI)
qed auto
qed
end
Theory BVSpec
section ‹The Bytecode Verifier \label{sec:BVSpec}›
theory BVSpec
imports Effect
begin
text ‹
This theory contains a specification of the BV. The specification
describes correct typings of method bodies; it corresponds
to type \emph{checking}.
›
definition
check_types :: "'m prog ⇒ nat ⇒ nat ⇒ ty⇩i' err list ⇒ bool"
where
"check_types P mxs mxl τs ≡ set τs ⊆ states P mxs mxl"
definition
wt_instr :: "['m prog,ty,nat,pc,ex_table,instr,pc,ty⇩m] ⇒ bool"
("_,_,_,_,_ ⊢ _,_ :: _" [60,0,0,0,0,0,0,61] 60)
where
"P,T,mxs,mpc,xt ⊢ i,pc :: τs ≡
app i P mxs T pc mpc xt (τs!pc) ∧
(∀(pc',τ') ∈ set (eff i P pc xt (τs!pc)). P ⊢ τ' ≤' τs!pc')"
definition wt_start :: "['m prog,cname,ty list,nat,ty⇩m] ⇒ bool"
where
"wt_start P C Ts mxl⇩0 τs ≡
P ⊢ Some ([],OK (Class C)#map OK Ts@replicate mxl⇩0 Err) ≤' τs!0"
definition wt_method :: "['m prog,cname,ty list,ty,nat,nat,instr list,
ex_table,ty⇩m] ⇒ bool"
where
"wt_method P C Ts T⇩r mxs mxl⇩0 is xt τs ≡
0 < size is ∧ size τs = size is ∧
check_types P mxs (1+size Ts+mxl⇩0) (map OK τs) ∧
wt_start P C Ts mxl⇩0 τs ∧
(∀pc < size is. P,T⇩r,mxs,size is,xt ⊢ is!pc,pc :: τs)"
definition wf_jvm_prog_phi :: "ty⇩P ⇒ jvm_prog ⇒ bool" ("wf'_jvm'_prog⇘_⇙")
where
"wf_jvm_prog⇘Φ⇙ ≡
wf_prog (λP C (M,Ts,T⇩r,(mxs,mxl⇩0,is,xt)).
wt_method P C Ts T⇩r mxs mxl⇩0 is xt (Φ C M))"
definition wf_jvm_prog :: "jvm_prog ⇒ bool"
where
"wf_jvm_prog P ≡ ∃Φ. wf_jvm_prog⇘Φ⇙ P"
lemma wt_jvm_progD:
"wf_jvm_prog⇘Φ⇙ P ⟹ ∃wt. wf_prog wt P"
by (unfold wf_jvm_prog_phi_def, blast)
lemma wt_jvm_prog_impl_wt_instr:
"⟦ wf_jvm_prog⇘Φ⇙ P;
P ⊢ C sees M:Ts → T = (mxs,mxl⇩0,ins,xt) in C; pc < size ins ⟧
⟹ P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M"
apply (unfold wf_jvm_prog_phi_def)
apply (drule (1) sees_wf_mdecl)
apply (simp add: wf_mdecl_def wt_method_def)
done
lemma wt_jvm_prog_impl_wt_start:
"⟦ wf_jvm_prog⇘Φ⇙ P;
P ⊢ C sees M:Ts → T = (mxs,mxl⇩0,ins,xt) in C ⟧ ⟹
0 < size ins ∧ wt_start P C Ts mxl⇩0 (Φ C M)"
apply (unfold wf_jvm_prog_phi_def)
apply (drule (1) sees_wf_mdecl)
apply (simp add: wf_mdecl_def wt_method_def)
done
end
Theory TF_JVM
section ‹The Typing Framework for the JVM \label{sec:JVM}›
theory TF_JVM
imports "../DFA/Typing_Framework_err" EffectMono BVSpec
begin
definition exec :: "jvm_prog ⇒ nat ⇒ ty ⇒ ex_table ⇒ instr list ⇒ ty⇩i' err step_type"
where
"exec G maxs rT et bs ≡
err_step (size bs) (λpc. app (bs!pc) G maxs rT pc (size bs) et)
(λpc. eff (bs!pc) G pc et)"
locale JVM_sl =
fixes P :: jvm_prog and mxs and mxl⇩0
fixes Ts :: "ty list" and "is" and xt and T⇩r
fixes mxl and A and r and f and app and eff and step
defines [simp]: "mxl ≡ 1+size Ts+mxl⇩0"
defines [simp]: "A ≡ states P mxs mxl"
defines [simp]: "r ≡ JVM_SemiType.le P mxs mxl"
defines [simp]: "f ≡ JVM_SemiType.sup P mxs mxl"
defines [simp]: "app ≡ λpc. Effect.app (is!pc) P mxs T⇩r pc (size is) xt"
defines [simp]: "eff ≡ λpc. Effect.eff (is!pc) P pc xt"
defines [simp]: "step ≡ err_step (size is) app eff"
locale start_context = JVM_sl +
fixes p and C
assumes wf: "wf_prog p P"
assumes C: "is_class P C"
assumes Ts: "set Ts ⊆ types P"
fixes first :: ty⇩i' and start
defines [simp]:
"first ≡ Some ([],OK (Class C) # map OK Ts @ replicate mxl⇩0 Err)"
defines [simp]:
"start ≡ OK first # replicate (size is - 1) (OK None)"
subsection ‹Connecting JVM and Framework›
lemma (in JVM_sl) step_def_exec: "step ≡ exec P mxs T⇩r xt is"
by (simp add: exec_def)
lemma special_ex_swap_lemma [iff]:
"(? X. (? n. X = A n & P n) & Q X) = (? n. Q(A n) & P n)"
by blast
lemma ex_in_list [iff]:
"(∃n. ST ∈ list n A ∧ n ≤ mxs) = (set ST ⊆ A ∧ size ST ≤ mxs)"
by (unfold list_def) auto
lemma singleton_list:
"(∃n. [Class C] ∈ list n (types P) ∧ n ≤ mxs) = (is_class P C ∧ 0 < mxs)"
by auto
lemma set_drop_subset:
"set xs ⊆ A ⟹ set (drop n xs) ⊆ A"
by (auto dest: in_set_dropD)
lemma Suc_minus_minus_le:
"n < mxs ⟹ Suc (n - (n - b)) ≤ mxs"
by arith
lemma in_listE:
"⟦ xs ∈ list n A; ⟦size xs = n; set xs ⊆ A⟧ ⟹ P ⟧ ⟹ P"
by (unfold list_def) blast
declare is_relevant_entry_def [simp]
declare set_drop_subset [simp]
theorem (in start_context) exec_pres_type:
"pres_type step (size is) A"
apply (insert wf)
apply simp
apply (unfold JVM_states_unfold)
apply (rule pres_type_lift)
apply clarify
apply (rename_tac s pc pc' s')
apply (case_tac s)
apply simp
apply (drule effNone)
apply simp
apply (simp add: Effect.app_def xcpt_app_def Effect.eff_def
xcpt_eff_def norm_eff_def relevant_entries_def)
apply (case_tac "is!pc")
apply clarsimp
apply (frule listE_nth_in, assumption)
apply fastforce
apply fastforce
apply (fastforce simp add: typeof_lit_is_type)
apply fastforce
apply (fastforce dest: sees_field_is_type)
apply fastforce
apply fastforce
defer
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply (clarsimp split!: if_splits)
apply fastforce
apply (erule disjE)
prefer 2
apply fastforce
apply clarsimp
apply (rule conjI)
apply (drule (1) sees_wf_mdecl)
apply (clarsimp simp add: wf_mdecl_def)
apply arith
done
declare is_relevant_entry_def [simp del]
declare set_drop_subset [simp del]
lemma lesubstep_type_simple:
"xs [⊑⇘Product.le (=) r⇙] ys ⟹ set xs {⊑⇘r⇙} set ys"
apply (unfold lesubstep_type_def)
apply clarify
apply (simp add: set_conv_nth)
apply clarify
apply (drule le_listD, assumption)
apply (clarsimp simp add: lesub_def Product.le_def)
apply (rule exI)
apply (rule conjI)
apply (rule exI)
apply (rule conjI)
apply (rule sym)
apply assumption
apply assumption
apply assumption
done
declare is_relevant_entry_def [simp del]
lemma conjI2: "⟦ A; A ⟹ B ⟧ ⟹ A ∧ B" by blast
lemma (in JVM_sl) eff_mono:
"⟦wf_prog p P; pc < length is; s ⊑⇘sup_state_opt P⇙ t; app pc t⟧
⟹ set (eff pc s) {⊑⇘sup_state_opt P⇙} set (eff pc t)"
apply simp
apply (unfold Effect.eff_def)
apply (cases t)
apply (simp add: lesub_def)
apply (rename_tac a)
apply (cases s)
apply simp
apply (rename_tac b)
apply simp
apply (rule lesubstep_union)
prefer 2
apply (rule lesubstep_type_simple)
apply (simp add: xcpt_eff_def)
apply (rule le_listI)
apply (simp add: split_beta)
apply (simp add: split_beta)
apply (simp add: lesub_def fun_of_def)
apply (case_tac a)
apply (case_tac b)
apply simp
apply (subgoal_tac "size ab = size aa")
prefer 2
apply (clarsimp simp add: list_all2_lengthD)
apply simp
apply (clarsimp simp add: norm_eff_def lesubstep_type_def lesub_def iff del: sup_state_conv)
apply (rule exI)
apply (rule conjI2)
apply (rule imageI)
apply (clarsimp simp add: Effect.app_def iff del: sup_state_conv)
apply (drule (2) succs_mono)
apply blast
apply simp
apply (erule eff⇩i_mono)
apply simp
apply assumption
apply clarsimp
apply clarsimp
done
lemma (in JVM_sl) bounded_step: "bounded step (size is)"
apply simp
apply (unfold bounded_def err_step_def Effect.app_def Effect.eff_def)
apply (auto simp add: error_def map_snd_def split: err.splits option.splits)
done
theorem (in JVM_sl) step_mono:
"wf_prog wf_mb P ⟹ mono r step (size is) A"
apply (simp add: JVM_le_Err_conv)
apply (insert bounded_step)
apply (unfold JVM_states_unfold)
apply (rule mono_lift)
apply blast
apply (unfold app_mono_def lesub_def)
apply clarsimp
apply (erule (2) app_mono)
apply simp
apply clarify
apply (drule eff_mono)
apply (auto simp add: lesub_def)
done
lemma (in start_context) first_in_A [iff]: "OK first ∈ A"
using Ts C by (force intro!: list_appendI simp add: JVM_states_unfold)
lemma (in JVM_sl) wt_method_def2:
"wt_method P C' Ts T⇩r mxs mxl⇩0 is xt τs =
(is ≠ [] ∧
size τs = size is ∧
OK ` set τs ⊆ states P mxs mxl ∧
wt_start P C' Ts mxl⇩0 τs ∧
wt_app_eff (sup_state_opt P) app eff τs)"
apply (unfold wt_method_def wt_app_eff_def wt_instr_def lesub_def check_types_def)
apply auto
done
end
Theory BVExec
section ‹Kildall for the JVM \label{sec:JVM}›
theory BVExec
imports "../DFA/Abstract_BV" TF_JVM
begin
definition kiljvm :: "jvm_prog ⇒ nat ⇒ nat ⇒ ty ⇒
instr list ⇒ ex_table ⇒ ty⇩i' err list ⇒ ty⇩i' err list"
where
"kiljvm P mxs mxl T⇩r is xt ≡
kildall (JVM_SemiType.le P mxs mxl) (JVM_SemiType.sup P mxs mxl)
(exec P mxs T⇩r xt is)"
definition wt_kildall :: "jvm_prog ⇒ cname ⇒ ty list ⇒ ty ⇒ nat ⇒ nat ⇒
instr list ⇒ ex_table ⇒ bool"
where
"wt_kildall P C' Ts T⇩r mxs mxl⇩0 is xt ≡
0 < size is ∧
(let first = Some ([],[OK (Class C')]@(map OK Ts)@(replicate mxl⇩0 Err));
start = OK first#(replicate (size is - 1) (OK None));
result = kiljvm P mxs (1+size Ts+mxl⇩0) T⇩r is xt start
in ∀n < size is. result!n ≠ Err)"
definition wf_jvm_prog⇩k :: "jvm_prog ⇒ bool"
where
"wf_jvm_prog⇩k P ≡
wf_prog (λP C' (M,Ts,T⇩r,(mxs,mxl⇩0,is,xt)). wt_kildall P C' Ts T⇩r mxs mxl⇩0 is xt) P"
theorem (in start_context) is_bcv_kiljvm:
"is_bcv r Err step (size is) A (kiljvm P mxs mxl T⇩r is xt)"
apply (insert wf)
apply (unfold kiljvm_def)
apply (fold r_def f_def step_def_exec)
apply (rule is_bcv_kildall)
apply simp apply (rule Semilat.intro)
apply (fold sl_def2)
apply (erule semilat_JVM)
apply simp
apply blast
apply (simp add: JVM_le_unfold)
apply (rule exec_pres_type)
apply (rule bounded_step)
apply (erule step_mono)
done
lemma subset_replicate [intro?]: "set (replicate n x) ⊆ {x}"
by (induct n) auto
lemma in_set_replicate:
assumes "x ∈ set (replicate n y)"
shows "x = y"
proof -
note assms
also have "set (replicate n y) ⊆ {y}" ..
finally show ?thesis by simp
qed
lemma (in start_context) start_in_A [intro?]:
"0 < size is ⟹ start ∈ list (size is) A"
using Ts C
apply (simp add: JVM_states_unfold)
apply (force intro!: listI list_appendI dest!: in_set_replicate)
done
theorem (in start_context) wt_kil_correct:
assumes wtk: "wt_kildall P C Ts T⇩r mxs mxl⇩0 is xt"
shows "∃τs. wt_method P C Ts T⇩r mxs mxl⇩0 is xt τs"
proof -
from wtk obtain res where
result: "res = kiljvm P mxs mxl T⇩r is xt start" and
success: "∀n < size is. res!n ≠ Err" and
instrs: "0 < size is"
by (unfold wt_kildall_def) simp
have bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T⇩r is xt)"
by (rule is_bcv_kiljvm)
from instrs have "start ∈ list (size is) A" ..
with bcv success result have
"∃ts∈list (size is) A. start [⊑⇩r] ts ∧ wt_step r Err step ts"
by (unfold is_bcv_def) blast
then obtain τs' where
in_A: "τs' ∈ list (size is) A" and
s: "start [⊑⇩r] τs'" and
w: "wt_step r Err step τs'"
by blast
hence wt_err_step: "wt_err_step (sup_state_opt P) step τs'"
by (simp add: wt_err_step_def JVM_le_Err_conv)
from in_A have l: "size τs' = size is" by simp
moreover {
from in_A have "check_types P mxs mxl τs'" by (simp add: check_types_def)
also from w have "∀x ∈ set τs'. x ≠ Err"
by (auto simp add: wt_step_def all_set_conv_all_nth)
hence [symmetric]: "map OK (map ok_val τs') = τs'"
by (auto intro!: map_idI simp add: wt_step_def)
finally have "check_types P mxs mxl (map OK (map ok_val τs'))" .
}
moreover {
from s have "start!0 ⊑⇩r τs'!0" by (rule le_listD) simp
moreover
from instrs w l
have "τs'!0 ≠ Err" by (unfold wt_step_def) simp
then obtain τs0 where "τs'!0 = OK τs0" by auto
ultimately
have "wt_start P C Ts mxl⇩0 (map ok_val τs')" using l instrs
by (unfold wt_start_def)
(simp add: lesub_def JVM_le_Err_conv Err.le_def)
}
moreover
from in_A have "set τs' ⊆ A" by simp
with wt_err_step bounded_step
have "wt_app_eff (sup_state_opt P) app eff (map ok_val τs')"
by (auto intro: wt_err_imp_wt_app_eff simp add: l)
ultimately
have "wt_method P C Ts T⇩r mxs mxl⇩0 is xt (map ok_val τs')"
using instrs by (simp add: wt_method_def2 check_types_def del: map_map)
thus ?thesis by blast
qed
theorem (in start_context) wt_kil_complete:
assumes wtm: "wt_method P C Ts T⇩r mxs mxl⇩0 is xt τs"
shows "wt_kildall P C Ts T⇩r mxs mxl⇩0 is xt"
proof -
from wtm obtain
instrs: "0 < size is" and
length: "length τs = length is" and
ck_type: "check_types P mxs mxl (map OK τs)" and
wt_start: "wt_start P C Ts mxl⇩0 τs" and
app_eff: "wt_app_eff (sup_state_opt P) app eff τs"
by (simp add: wt_method_def2 check_types_def)
from ck_type
have in_A: "set (map OK τs) ⊆ A"
by (simp add: check_types_def)
with app_eff in_A bounded_step
have "wt_err_step (sup_state_opt P) (err_step (size τs) app eff) (map OK τs)"
by - (erule wt_app_eff_imp_wt_err,
auto simp add: exec_def length states_def)
hence wt_err: "wt_err_step (sup_state_opt P) step (map OK τs)"
by (simp add: length)
have is_bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T⇩r is xt)"
by (rule is_bcv_kiljvm)
moreover from instrs have "start ∈ list (size is) A" ..
moreover
let ?τs = "map OK τs"
have less_τs: "start [⊑⇩r] ?τs"
proof (rule le_listI)
from length instrs
show "length start = length (map OK τs)" by simp
next
fix n
from wt_start have "P ⊢ ok_val (start!0) ≤' τs!0"
by (simp add: wt_start_def)
moreover from instrs length have "0 < length τs" by simp
ultimately have "start!0 ⊑⇩r ?τs!0"
by (simp add: JVM_le_Err_conv lesub_def)
moreover {
fix n'
have "OK None ⊑⇩r ?τs!n"
by (auto simp add: JVM_le_Err_conv Err.le_def lesub_def
split: err.splits)
hence "⟦n = Suc n'; n < size start⟧ ⟹ start!n ⊑⇩r ?τs!n" by simp
}
ultimately
show "n < size start ⟹ start!n ⊑⇩r ?τs!n" by (cases n, blast+)
qed
moreover
from ck_type length
have "?τs ∈ list (size is) A"
by (auto intro!: listI simp add: check_types_def)
moreover
from wt_err have "wt_step r Err step ?τs"
by (simp add: wt_err_step_def JVM_le_Err_conv)
ultimately
have "∀p. p < size is ⟶ kiljvm P mxs mxl T⇩r is xt start ! p ≠ Err"
by (unfold is_bcv_def) blast
with instrs
show "wt_kildall P C Ts T⇩r mxs mxl⇩0 is xt" by (unfold wt_kildall_def) simp
qed
theorem jvm_kildall_correct:
"wf_jvm_prog⇩k P = wf_jvm_prog P"
proof
let ?Φ = "λC M. let (C,Ts,T⇩r,(mxs,mxl⇩0,is,xt)) = method P C M in
SOME τs. wt_method P C Ts T⇩r mxs mxl⇩0 is xt τs"
assume wt: "wf_jvm_prog⇩k P"
hence "wf_jvm_prog⇘?Φ⇙ P"
apply (unfold wf_jvm_prog_phi_def wf_jvm_prog⇩k_def)
apply (erule wf_prog_lift)
apply (auto dest!: start_context.wt_kil_correct [OF start_context.intro]
intro: someI)
apply (erule sees_method_is_class)
done
thus "wf_jvm_prog P" by (unfold wf_jvm_prog_def) fast
next
assume wt: "wf_jvm_prog P"
thus "wf_jvm_prog⇩k P"
apply (unfold wf_jvm_prog_def wf_jvm_prog_phi_def wf_jvm_prog⇩k_def)
apply (clarify)
apply (erule wf_prog_lift)
apply (auto intro!: start_context.wt_kil_complete start_context.intro)
apply (erule sees_method_is_class)
done
qed
end
Theory LBVJVM
section ‹LBV for the JVM \label{sec:JVM}›
theory LBVJVM
imports "../DFA/Abstract_BV" TF_JVM
begin
type_synonym prog_cert = "cname ⇒ mname ⇒ ty⇩i' err list"
definition check_cert :: "jvm_prog ⇒ nat ⇒ nat ⇒ nat ⇒ ty⇩i' err list ⇒ bool"
where
"check_cert P mxs mxl n cert ≡ check_types P mxs mxl cert ∧ size cert = n+1 ∧
(∀i<n. cert!i ≠ Err) ∧ cert!n = OK None"
definition lbvjvm :: "jvm_prog ⇒ nat ⇒ nat ⇒ ty ⇒ ex_table ⇒
ty⇩i' err list ⇒ instr list ⇒ ty⇩i' err ⇒ ty⇩i' err"
where
"lbvjvm P mxs maxr T⇩r et cert bs ≡
wtl_inst_list bs cert (JVM_SemiType.sup P mxs maxr) (JVM_SemiType.le P mxs maxr) Err (OK None) (exec P mxs T⇩r et bs) 0"
definition wt_lbv :: "jvm_prog ⇒ cname ⇒ ty list ⇒ ty ⇒ nat ⇒ nat ⇒
ex_table ⇒ ty⇩i' err list ⇒ instr list ⇒ bool"
where
"wt_lbv P C Ts T⇩r mxs mxl⇩0 et cert ins ≡
check_cert P mxs (1+size Ts+mxl⇩0) (size ins) cert ∧
0 < size ins ∧
(let start = Some ([],(OK (Class C))#((map OK Ts))@(replicate mxl⇩0 Err));
result = lbvjvm P mxs (1+size Ts+mxl⇩0) T⇩r et cert ins (OK start)
in result ≠ Err)"
definition wt_jvm_prog_lbv :: "jvm_prog ⇒ prog_cert ⇒ bool"
where
"wt_jvm_prog_lbv P cert ≡
wf_prog (λP C (mn,Ts,T⇩r,(mxs,mxl⇩0,b,et)). wt_lbv P C Ts T⇩r mxs mxl⇩0 et (cert C mn) b) P"
definition mk_cert :: "jvm_prog ⇒ nat ⇒ ty ⇒ ex_table ⇒ instr list
⇒ ty⇩m ⇒ ty⇩i' err list"
where
"mk_cert P mxs T⇩r et bs phi ≡ make_cert (exec P mxs T⇩r et bs) (map OK phi) (OK None)"
definition prg_cert :: "jvm_prog ⇒ ty⇩P ⇒ prog_cert"
where
"prg_cert P phi C mn ≡ let (C,Ts,T⇩r,(mxs,mxl⇩0,ins,et)) = method P C mn
in mk_cert P mxs T⇩r et ins (phi C mn)"
lemma check_certD [intro?]:
"check_cert P mxs mxl n cert ⟹ cert_ok cert n Err (OK None) (states P mxs mxl)"
by (unfold cert_ok_def check_cert_def check_types_def) auto
lemma (in start_context) wt_lbv_wt_step:
assumes lbv: "wt_lbv P C Ts T⇩r mxs mxl⇩0 xt cert is"
shows "∃τs ∈ list (size is) A. wt_step r Err step τs ∧ OK first ⊑⇩r τs!0"
proof -
from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
hence "semilat (A, r, f)" by (simp add: sl_def2)
moreover have "top r Err" by (simp add: JVM_le_Err_conv)
moreover have "Err ∈ A" by (simp add: JVM_states_unfold)
moreover have "bottom r (OK None)"
by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
moreover have "OK None ∈ A" by (simp add: JVM_states_unfold)
moreover note bounded_step
moreover from lbv have "cert_ok cert (size is) Err (OK None) A"
by (unfold wt_lbv_def) (auto dest: check_certD)
moreover note exec_pres_type
moreover
from lbv
have "wtl_inst_list is cert f r Err (OK None) step 0 (OK first) ≠ Err"
by (simp add: wt_lbv_def lbvjvm_def step_def_exec [symmetric])
moreover note first_in_A
moreover from lbv have "0 < size is" by (simp add: wt_lbv_def)
ultimately show ?thesis by (rule lbvs.wtl_sound_strong [OF lbvs.intro, OF lbv.intro lbvs_axioms.intro, OF Semilat.intro lbv_axioms.intro])
qed
lemma (in start_context) wt_lbv_wt_method:
assumes lbv: "wt_lbv P C Ts T⇩r mxs mxl⇩0 xt cert is"
shows "∃τs. wt_method P C Ts T⇩r mxs mxl⇩0 is xt τs"
proof -
from lbv have l: "is ≠ []" by (simp add: wt_lbv_def)
moreover
from wf lbv C Ts obtain τs where
list: "τs ∈ list (size is) A" and
step: "wt_step r Err step τs" and
start: "OK first ⊑⇩r τs!0"
by (blast dest: wt_lbv_wt_step)
from list have [simp]: "size τs = size is" by simp
have "size (map ok_val τs) = size is" by simp
moreover from l have 0: "0 < size τs" by simp
with step obtain τs0 where "τs!0 = OK τs0"
by (unfold wt_step_def) blast
with start 0 have "wt_start P C Ts mxl⇩0 (map ok_val τs)"
by (simp add: wt_start_def JVM_le_Err_conv lesub_def Err.le_def)
moreover {
from list have "check_types P mxs mxl τs" by (simp add: check_types_def)
also from step have "∀x ∈ set τs. x ≠ Err"
by (auto simp add: all_set_conv_all_nth wt_step_def)
hence [symmetric]: "map OK (map ok_val τs) = τs"
by (auto intro!: map_idI)
finally have "check_types P mxs mxl (map OK (map ok_val τs))" .
}
moreover {
note bounded_step
moreover from list have "set τs ⊆ A" by simp
moreover from step have "wt_err_step (sup_state_opt P) step τs"
by (simp add: wt_err_step_def JVM_le_Err_conv)
ultimately have "wt_app_eff (sup_state_opt P) app eff (map ok_val τs)"
by (auto intro: wt_err_imp_wt_app_eff simp add: exec_def states_def)
}
ultimately have "wt_method P C Ts T⇩r mxs mxl⇩0 is xt (map ok_val τs)"
by (simp add: wt_method_def2 check_types_def del: map_map)
thus ?thesis ..
qed
lemma (in start_context) wt_method_wt_lbv:
assumes wt: "wt_method P C Ts T⇩r mxs mxl⇩0 is xt τs"
defines [simp]: "cert ≡ mk_cert P mxs T⇩r xt is τs"
shows "wt_lbv P C Ts T⇩r mxs mxl⇩0 xt cert is"
proof -
let ?τs = "map OK τs"
let ?cert = "make_cert step ?τs (OK None)"
from wt obtain
0: "0 < size is" and
size: "size is = size ?τs" and
ck_types: "check_types P mxs mxl ?τs" and
wt_start: "wt_start P C Ts mxl⇩0 τs" and
app_eff: "wt_app_eff (sup_state_opt P) app eff τs"
by (force simp add: wt_method_def2 check_types_def)
from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
hence "semilat (A, r, f)" by (simp add: sl_def2)
moreover have "top r Err" by (simp add: JVM_le_Err_conv)
moreover have "Err ∈ A" by (simp add: JVM_states_unfold)
moreover have "bottom r (OK None)"
by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
moreover have "OK None ∈ A" by (simp add: JVM_states_unfold)
moreover from wf have "mono r step (size is) A" by (rule step_mono)
hence "mono r step (size ?τs) A" by (simp add: size)
moreover from exec_pres_type
have "pres_type step (size ?τs) A" by (simp add: size)
moreover
from ck_types have τs_in_A: "set ?τs ⊆ A" by (simp add: check_types_def)
hence "∀pc. pc < size ?τs ⟶ ?τs!pc ∈ A ∧ ?τs!pc ≠ Err" by auto
moreover from bounded_step
have "bounded step (size ?τs)" by (simp add: size)
moreover have "OK None ≠ Err" by simp
moreover from bounded_step size τs_in_A app_eff
have "wt_err_step (sup_state_opt P) step ?τs"
by (auto intro: wt_app_eff_imp_wt_err simp add: exec_def states_def)
hence "wt_step r Err step ?τs"
by (simp add: wt_err_step_def JVM_le_Err_conv)
moreover
from 0 size have "0 < size τs" by auto
hence "?τs!0 = OK (τs!0)" by simp
with wt_start have "OK first ⊑⇩r ?τs!0"
by (clarsimp simp add: wt_start_def lesub_def Err.le_def JVM_le_Err_conv)
moreover note first_in_A
moreover have "OK first ≠ Err" by simp
moreover note size
ultimately
have "wtl_inst_list is ?cert f r Err (OK None) step 0 (OK first) ≠ Err"
by (rule lbvc.wtl_complete [OF lbvc.intro, OF lbv.intro lbvc_axioms.intro, OF Semilat.intro lbv_axioms.intro])
moreover from 0 size have "τs ≠ []" by auto
moreover from ck_types have "check_types P mxs mxl ?cert"
apply (auto simp add: make_cert_def check_types_def JVM_states_unfold)
apply (subst Ok_in_err [symmetric])
apply (drule nth_mem)
apply auto
done
moreover note 0 size
ultimately show ?thesis
by (simp add: wt_lbv_def lbvjvm_def mk_cert_def step_def_exec [symmetric]
check_cert_def make_cert_def nth_append)
qed
theorem jvm_lbv_correct:
"wt_jvm_prog_lbv P Cert ⟹ wf_jvm_prog P"
proof -
let ?Φ = "λC mn. let (C,Ts,T⇩r,(mxs,mxl⇩0,is,xt)) = method P C mn in
SOME τs. wt_method P C Ts T⇩r mxs mxl⇩0 is xt τs"
assume wt: "wt_jvm_prog_lbv P Cert"
hence "wf_jvm_prog⇘?Φ⇙ P"
apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
apply (erule wf_prog_lift)
apply (auto dest!: start_context.wt_lbv_wt_method [OF start_context.intro]
intro: someI)
apply (erule sees_method_is_class)
done
thus ?thesis by (unfold wf_jvm_prog_def) blast
qed
theorem jvm_lbv_complete:
assumes wt: "wf_jvm_prog⇘Φ⇙ P"
shows "wt_jvm_prog_lbv P (prg_cert P Φ)"
using wt
apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
apply (erule wf_prog_lift)
apply (auto simp add: prg_cert_def
intro!: start_context.wt_method_wt_lbv start_context.intro)
apply (erule sees_method_is_class)
done
end
Theory BVConform
section ‹BV Type Safety Invariant›
theory BVConform
imports BVSpec "../JVM/JVMExec" "../Common/Conform"
begin
definition confT :: "'c prog ⇒ heap ⇒ val ⇒ ty err ⇒ bool"
("_,_ ⊢ _ :≤⇩⊤ _" [51,51,51,51] 50)
where
"P,h ⊢ v :≤⇩⊤ E ≡ case E of Err ⇒ True | OK T ⇒ P,h ⊢ v :≤ T"
notation (ASCII)
confT ("_,_ |- _ :<=T _" [51,51,51,51] 50)
abbreviation
confTs :: "'c prog ⇒ heap ⇒ val list ⇒ ty⇩l ⇒ bool"
("_,_ ⊢ _ [:≤⇩⊤] _" [51,51,51,51] 50) where
"P,h ⊢ vs [:≤⇩⊤] Ts ≡ list_all2 (confT P h) vs Ts"
notation (ASCII)
confTs ("_,_ |- _ [:<=T] _" [51,51,51,51] 50)
definition conf_f :: "jvm_prog ⇒ heap ⇒ ty⇩i ⇒ bytecode ⇒ frame ⇒ bool"
where
"conf_f P h ≡ λ(ST,LT) is (stk,loc,C,M,pc).
P,h ⊢ stk [:≤] ST ∧ P,h ⊢ loc [:≤⇩⊤] LT ∧ pc < size is"
lemma conf_f_def2:
"conf_f P h (ST,LT) is (stk,loc,C,M,pc) ≡
P,h ⊢ stk [:≤] ST ∧ P,h ⊢ loc [:≤⇩⊤] LT ∧ pc < size is"
by (simp add: conf_f_def)
primrec conf_fs :: "[jvm_prog,heap,ty⇩P,mname,nat,ty,frame list] ⇒ bool"
where
"conf_fs P h Φ M⇩0 n⇩0 T⇩0 [] = True"
| "conf_fs P h Φ M⇩0 n⇩0 T⇩0 (f#frs) =
(let (stk,loc,C,M,pc) = f in
(∃ST LT Ts T mxs mxl⇩0 is xt.
Φ C M ! pc = Some (ST,LT) ∧
(P ⊢ C sees M:Ts → T = (mxs,mxl⇩0,is,xt) in C) ∧
(∃D Ts' T' m D'.
is!pc = (Invoke M⇩0 n⇩0) ∧ ST!n⇩0 = Class D ∧
P ⊢ D sees M⇩0:Ts' → T' = m in D' ∧ P ⊢ T⇩0 ≤ T') ∧
conf_f P h (ST, LT) is f ∧ conf_fs P h Φ M (size Ts) T frs))"
definition correct_state :: "[jvm_prog,ty⇩P,jvm_state] ⇒ bool" ("_,_ ⊢ _ √" [61,0,0] 61)
where
"correct_state P Φ ≡ λ(xp,h,frs).
case xp of
None ⇒ (case frs of
[] ⇒ True
| (f#fs) ⇒ P⊢ h√ ∧
(let (stk,loc,C,M,pc) = f
in ∃Ts T mxs mxl⇩0 is xt τ.
(P ⊢ C sees M:Ts→T = (mxs,mxl⇩0,is,xt) in C) ∧
Φ C M ! pc = Some τ ∧
conf_f P h τ is f ∧ conf_fs P h Φ M (size Ts) T fs))
| Some x ⇒ frs = []"
notation
correct_state ("_,_ |- _ [ok]" [61,0,0] 61)
subsection ‹Values and ‹⊤››
lemma confT_Err [iff]: "P,h ⊢ x :≤⇩⊤ Err"
by (simp add: confT_def)
lemma confT_OK [iff]: "P,h ⊢ x :≤⇩⊤ OK T = (P,h ⊢ x :≤ T)"
by (simp add: confT_def)
lemma confT_cases:
"P,h ⊢ x :≤⇩⊤ X = (X = Err ∨ (∃T. X = OK T ∧ P,h ⊢ x :≤ T))"
by (cases X) auto
lemma confT_hext [intro?, trans]:
"⟦ P,h ⊢ x :≤⇩⊤ T; h ⊴ h' ⟧ ⟹ P,h' ⊢ x :≤⇩⊤ T"
by (cases T) (blast intro: conf_hext)+
lemma confT_widen [intro?, trans]:
"⟦ P,h ⊢ x :≤⇩⊤ T; P ⊢ T ≤⇩⊤ T' ⟧ ⟹ P,h ⊢ x :≤⇩⊤ T'"
by (cases T', auto intro: conf_widen)
subsection ‹Stack and Registers›
lemmas confTs_Cons1 [iff] = list_all2_Cons1 [of "confT P h"] for P h
lemma confTs_confT_sup:
"⟦ P,h ⊢ loc [:≤⇩⊤] LT; n < size LT; LT!n = OK T; P ⊢ T ≤ T' ⟧
⟹ P,h ⊢ (loc!n) :≤ T'"
apply (frule list_all2_lengthD)
apply (drule list_all2_nthD, simp)
apply simp
apply (erule conf_widen, assumption+)
done
lemma confTs_hext [intro?]:
"P,h ⊢ loc [:≤⇩⊤] LT ⟹ h ⊴ h' ⟹ P,h' ⊢ loc [:≤⇩⊤] LT"
by (fast elim: list_all2_mono confT_hext)
lemma confTs_widen [intro?, trans]:
"P,h ⊢ loc [:≤⇩⊤] LT ⟹ P ⊢ LT [≤⇩⊤] LT' ⟹ P,h ⊢ loc [:≤⇩⊤] LT'"
by (rule list_all2_trans, rule confT_widen)
lemma confTs_map [iff]:
"⋀vs. (P,h ⊢ vs [:≤⇩⊤] map OK Ts) = (P,h ⊢ vs [:≤] Ts)"
by (induct Ts) (auto simp add: list_all2_Cons2)
lemma reg_widen_Err [iff]:
"⋀LT. (P ⊢ replicate n Err [≤⇩⊤] LT) = (LT = replicate n Err)"
by (induct n) (auto simp add: list_all2_Cons1)
lemma confTs_Err [iff]:
"P,h ⊢ replicate n v [:≤⇩⊤] replicate n Err"
by (induct n) auto
subsection ‹correct-frames›
lemmas [simp del] = fun_upd_apply
lemma conf_fs_hext:
"⋀M n T⇩r.
⟦ conf_fs P h Φ M n T⇩r frs; h ⊴ h' ⟧ ⟹ conf_fs P h' Φ M n T⇩r frs"
apply (induct frs)
apply simp
apply clarify
apply (simp (no_asm_use))
apply clarify
apply (unfold conf_f_def)
apply (simp (no_asm_use))
apply clarify
apply (fast elim!: confs_hext confTs_hext)
done
end
Theory BVSpecTypeSafe
section ‹BV Type Safety Proof \label{sec:BVSpecTypeSafe}›
theory BVSpecTypeSafe
imports BVConform
begin
text ‹
This theory contains proof that the specification of the bytecode
verifier only admits type safe programs.
›
subsection ‹Preliminaries›
text ‹
Simp and intro setup for the type safety proof:
›
lemmas defs1 = correct_state_def conf_f_def wt_instr_def eff_def norm_eff_def app_def xcpt_app_def
lemmas widen_rules [intro] = conf_widen confT_widen confs_widens confTs_widen
subsection ‹Exception Handling›
text ‹
For the ‹Invoke› instruction the BV has checked all handlers
that guard the current ‹pc›.
›
lemma Invoke_handlers:
"match_ex_table P C pc xt = Some (pc',d') ⟹
∃(f,t,D,h,d) ∈ set (relevant_entries P (Invoke n M) pc xt).
P ⊢ C ≼⇧* D ∧ pc ∈ {f..<t} ∧ pc' = h ∧ d' = d"
by (induct xt) (auto simp add: relevant_entries_def matches_ex_entry_def
is_relevant_entry_def split: if_split_asm)
text ‹
We can prove separately that the recursive search for exception
handlers (‹find_handler›) in the frame stack results in
a conforming state (if there was no matching exception handler
in the current frame). We require that the exception is a valid
heap address, and that the state before the exception occurred
conforms.
› term find_handler
lemma uncaught_xcpt_correct:
assumes wt: "wf_jvm_prog⇘Φ⇙ P"
assumes h: "h xcp = Some obj"
shows "⋀f. P,Φ ⊢ (None, h, f#frs)√ ⟹ P,Φ ⊢ (find_handler P xcp h frs) √"
(is "⋀f. ?correct (None, h, f#frs) ⟹ ?correct (?find frs)")
proof (induct frs)
show "?correct (?find [])" by (simp add: correct_state_def)
next
from wt obtain mb where wf: "wf_prog mb P" by (simp add: wf_jvm_prog_phi_def)
fix f f' frs' assume cr: "?correct (None, h, f#f'#frs')"
assume IH: "⋀f. ?correct (None, h, f#frs') ⟹ ?correct (?find frs')"
from cr have cr': "?correct (None, h, f'#frs')"
by (fastforce simp add: correct_state_def)
obtain stk loc C M pc where [simp]: "f' = (stk,loc,C,M,pc)" by (cases f')
from cr obtain Ts T mxs mxl⇩0 ins xt where
meth: "P ⊢ C sees M:Ts → T = (mxs,mxl⇩0,ins,xt) in C"
by (simp add: correct_state_def, blast)
hence [simp]: "ex_table_of P C M = xt" by simp
show "?correct (?find (f'#frs'))"
proof (cases "match_ex_table P (cname_of h xcp) pc xt")
case None with cr' IH [of f'] show ?thesis by fastforce
next
fix pc_d
assume "match_ex_table P (cname_of h xcp) pc xt = Some pc_d"
then obtain pc' d' where
match: "match_ex_table P (cname_of h xcp) pc xt = Some (pc',d')"
(is "?match (cname_of h xcp) = _")
by (cases pc_d) auto
from wt meth cr' [simplified]
have wti: "P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M"
by (fastforce simp add: correct_state_def conf_f_def
dest: sees_method_fun
elim!: wt_jvm_prog_impl_wt_instr)
from cr meth
obtain n M' ST LT where
ins: "ins!pc = Invoke n M'" (is "_ = ?i") and
Φ: "Φ C M ! pc = Some (ST, LT)"
by (fastforce dest: sees_method_fun simp add: correct_state_def)
from ins match obtain f t D where
rel: "(f,t,D,pc',d') ∈ set (relevant_entries P (ins!pc) pc xt)" and
D: "P ⊢ cname_of h xcp ≼⇧* D"
by (fastforce dest: Invoke_handlers)
from rel have
"(pc', Some (Class D # drop (size ST - d') ST, LT)) ∈ set (xcpt_eff (ins!pc) P pc (ST,LT) xt)"
(is "(_, Some (?ST',_)) ∈ _")
by (force simp add: xcpt_eff_def image_def)
with wti Φ obtain
pc: "pc' < size ins" and
"P ⊢ Some (?ST', LT) ≤' Φ C M ! pc'"
by (clarsimp simp add: defs1) blast
then obtain ST' LT' where
Φ': "Φ C M ! pc' = Some (ST',LT')" and
less: "P ⊢ (?ST', LT) ≤⇩i (ST',LT')"
by (auto simp add: sup_state_opt_any_Some)
from cr' Φ meth have "conf_f P h (ST, LT) ins f'"
by (unfold correct_state_def) (fastforce dest: sees_method_fun)
hence loc: "P,h ⊢ loc [:≤⇩⊤] LT" and
stk: "P,h ⊢ stk [:≤] ST" by (unfold conf_f_def) auto
hence [simp]: "size stk = size ST" by (simp add: list_all2_lengthD)
let ?f = "(Addr xcp # drop (length stk - d') stk, loc, C, M, pc')"
have "conf_f P h (ST',LT') ins ?f"
proof -
from wf less loc have "P,h ⊢ loc [:≤⇩⊤] LT'" by simp blast
moreover from D h have "P,h ⊢ Addr xcp :≤ Class D"
by (simp add: conf_def obj_ty_def case_prod_unfold)
with less stk
have "P,h ⊢ Addr xcp # drop (length stk - d') stk [:≤] ST'"
by (auto intro!: list_all2_dropI)
ultimately show ?thesis using pc by (simp add: conf_f_def)
qed
with cr' match Φ' meth pc
show ?thesis by (unfold correct_state_def) (fastforce dest: sees_method_fun)
qed
qed
text ‹
The requirement of lemma ‹uncaught_xcpt_correct› (that
the exception is a valid reference on the heap) is always met
for welltyped instructions and conformant states:
›
lemma exec_instr_xcpt_h:
"⟦ fst (exec_instr (ins!pc) P h stk vars Cl M pc frs) = Some xcp;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ ∃obj. h xcp = Some obj"
(is "⟦ ?xcpt; ?wt; ?correct ⟧ ⟹ ?thesis")
proof -
note [simp] = split_beta
note [split] = if_split_asm option.split_asm
assume wt: ?wt ?correct
hence pre: "preallocated h" by (simp add: correct_state_def hconf_def)
assume xcpt: ?xcpt with pre show ?thesis
proof (cases "ins!pc")
case Throw with xcpt wt pre show ?thesis
by (clarsimp iff: list_all2_Cons2 simp add: defs1)
(auto dest: non_npD simp: is_refT_def elim: preallocatedE)
qed (auto elim: preallocatedE)
qed
lemma conf_sys_xcpt:
"⟦preallocated h; C ∈ sys_xcpts⟧ ⟹ P,h ⊢ Addr (addr_of_sys_xcpt C) :≤ Class C"
by (auto elim: preallocatedE)
lemma match_ex_table_SomeD:
"match_ex_table P C pc xt = Some (pc',d') ⟹
∃(f,t,D,h,d) ∈ set xt. matches_ex_entry P C pc (f,t,D,h,d) ∧ h = pc' ∧ d=d'"
by (induct xt) (auto split: if_split_asm)
text ‹
Finally we can state that, whenever an exception occurs, the
next state always conforms:
›
lemma xcpt_correct:
fixes σ' :: jvm_state
assumes wtp: "wf_jvm_prog⇘Φ⇙ P"
assumes meth: "P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C"
assumes wt: "P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M"
assumes xp: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = Some xcp"
assumes s': "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
assumes correct: "P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√"
shows "P,Φ ⊢ σ'√"
proof -
from wtp obtain wfmb where wf: "wf_prog wfmb P"
by (simp add: wf_jvm_prog_phi_def)
note conf_sys_xcpt [elim!]
note xp' = meth s' xp
note wtp
moreover
from xp wt correct
obtain obj where h: "h xcp = Some obj" by (blast dest: exec_instr_xcpt_h)
moreover note correct
ultimately
have "P,Φ ⊢ find_handler P xcp h frs √" by (rule uncaught_xcpt_correct)
with xp'
have "match_ex_table P (cname_of h xcp) pc xt = None ⟹ ?thesis"
(is "?m (cname_of h xcp) = _ ⟹ _" is "?match = _ ⟹ _")
by (simp add: split_beta)
moreover
{ fix pc_d assume "?match = Some pc_d"
then obtain pc' d' where some_handler: "?match = Some (pc',d')"
by (cases pc_d) auto
from correct meth
obtain ST LT where
h_ok: "P ⊢ h √" and
Φ_pc: "Φ C M ! pc = Some (ST, LT)" and
frame: "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
frames: "conf_fs P h Φ M (size Ts) T frs"
by (unfold correct_state_def) (fastforce dest: sees_method_fun)
from h_ok have preh: "preallocated h" by (simp add: hconf_def)
from frame obtain
stk: "P,h ⊢ stk [:≤] ST" and
loc: "P,h ⊢ loc [:≤⇩⊤] LT" and
pc: "pc < size ins"
by (unfold conf_f_def) auto
from stk have [simp]: "size stk = size ST" ..
from wt Φ_pc have
eff: "∀(pc', s')∈set (xcpt_eff (ins!pc) P pc (ST,LT) xt).
pc' < size ins ∧ P ⊢ s' ≤' Φ C M!pc'"
by (auto simp add: defs1)
let ?stk' = "Addr xcp # drop (length stk - d') stk"
let ?f = "(?stk', loc, C, M, pc')"
from some_handler xp'
have σ': "σ' = (None, h, ?f#frs)"
by (simp add: split_beta)
from some_handler obtain f t D where
xt: "(f,t,D,pc',d') ∈ set xt" and
"matches_ex_entry P (cname_of h xcp) pc (f,t,D,pc',d')"
by (auto dest: match_ex_table_SomeD)
hence match: "P ⊢ cname_of h xcp ≼⇧* D" "pc ∈ {f..<t}"
by (auto simp: matches_ex_entry_def)
from xp obtain
"(f,t,D,pc',d') ∈ set (relevant_entries P (ins!pc) pc xt)" and
conf: "P,h ⊢ Addr xcp :≤ Class D"
proof (cases "ins!pc")
case Return
with xp have False by (auto simp: split_beta split: if_split_asm)
thus ?thesis ..
next
case New with xp
have [simp]: "xcp = addr_of_sys_xcpt OutOfMemory" by simp
with New match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
by (simp add: is_relevant_entry_def)
with match preh xt
show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
next
case Getfield with xp
have [simp]: "xcp = addr_of_sys_xcpt NullPointer"
by (simp add: split_beta split: if_split_asm)
with Getfield match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
by (simp add: is_relevant_entry_def)
with match preh xt
show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
next
case Putfield with xp
have [simp]: "xcp = addr_of_sys_xcpt NullPointer"
by (simp add: split_beta split: if_split_asm)
with Putfield match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
by (simp add: is_relevant_entry_def)
with match preh xt
show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
next
case Checkcast with xp
have [simp]: "xcp = addr_of_sys_xcpt ClassCast"
by (simp add: split_beta split: if_split_asm)
with Checkcast match preh have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
by (simp add: is_relevant_entry_def)
with match preh xt
show ?thesis by (fastforce simp add: relevant_entries_def intro: that)
next
case Invoke with xp match
have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
by (simp add: is_relevant_entry_def)
moreover
from xp wt correct obtain obj where xcp: "h xcp = Some obj"
by (blast dest: exec_instr_xcpt_h)
ultimately
show ?thesis using xt match
by (auto simp add: relevant_entries_def conf_def case_prod_unfold intro: that)
next
case Throw with xp match preh
have "is_relevant_entry P (ins!pc) pc (f,t,D,pc',d')"
by (simp add: is_relevant_entry_def)
moreover
from xp wt correct obtain obj where xcp: "h xcp = Some obj"
by (blast dest: exec_instr_xcpt_h)
ultimately
show ?thesis using xt match
by (auto simp add: relevant_entries_def conf_def case_prod_unfold intro: that)
qed auto
with eff obtain ST' LT' where
Φ_pc': "Φ C M ! pc' = Some (ST', LT')" and
pc': "pc' < size ins" and
less: "P ⊢ (Class D # drop (size ST - d') ST, LT) ≤⇩i (ST', LT')"
by (fastforce simp add: xcpt_eff_def sup_state_opt_any_Some)
with conf loc stk have "conf_f P h (ST',LT') ins ?f"
by (auto simp add: defs1 intro: list_all2_dropI)
with meth h_ok frames Φ_pc' σ'
have ?thesis by (unfold correct_state_def) (fastforce dest: sees_method_fun)
}
ultimately
show ?thesis by (cases "?match") blast+
qed
subsection ‹Single Instructions›
text ‹
In this section we prove for each single (welltyped) instruction
that the state after execution of the instruction still conforms.
Since we have already handled exceptions above, we can now assume that
no exception occurs in this step.
›
declare defs1 [simp]
lemma Invoke_correct:
fixes σ' :: jvm_state
assumes wtprog: "wf_jvm_prog⇘Φ⇙ P"
assumes meth_C: "P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C"
assumes ins: "ins ! pc = Invoke M' n"
assumes wti: "P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M"
assumes σ': "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
assumes approx: "P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√"
assumes no_xcp: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"
shows "P,Φ ⊢ σ'√"
proof -
note split_paired_Ex [simp del]
from wtprog obtain wfmb where wfprog: "wf_prog wfmb P"
by (simp add: wf_jvm_prog_phi_def)
from ins meth_C approx obtain ST LT where
heap_ok: "P⊢ h√" and
Φ_pc: "Φ C M!pc = Some (ST,LT)" and
frame: "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
frames: "conf_fs P h Φ M (size Ts) T frs"
by (fastforce dest: sees_method_fun)
from ins wti Φ_pc
have n: "n < size ST" by simp
{ assume "stk!n = Null"
with ins no_xcp have False by (simp add: split_beta)
hence ?thesis ..
}
moreover
{ assume "ST!n = NT"
moreover
from frame have "P,h ⊢ stk [:≤] ST" by simp
with n have "P,h ⊢ stk!n :≤ ST!n" by (simp add: list_all2_conv_all_nth)
ultimately
have "stk!n = Null" by simp
with ins no_xcp have False by (simp add: split_beta)
hence ?thesis ..
}
moreover {
assume NT: "ST!n ≠ NT" and Null: "stk!n ≠ Null"
from NT ins wti Φ_pc obtain D D' Ts T m ST' LT' where
D: "ST!n = Class D" and
pc': "pc+1 < size ins" and
m_D: "P ⊢ D sees M': Ts→T = m in D'" and
Ts: "P ⊢ rev (take n ST) [≤] Ts" and
Φ': "Φ C M ! (pc+1) = Some (ST', LT')" and
LT': "P ⊢ LT [≤⇩⊤] LT'" and
ST': "P ⊢ (T # drop (n+1) ST) [≤] ST'"
by (clarsimp simp add: sup_state_opt_any_Some)
from frame obtain
stk: "P,h ⊢ stk [:≤] ST" and
loc: "P,h ⊢ loc [:≤⇩⊤] LT" by simp
from n stk D have "P,h ⊢ stk!n :≤ Class D"
by (auto simp add: list_all2_conv_all_nth)
with Null obtain a C' fs where
Addr: "stk!n = Addr a" and
obj: "h a = Some (C',fs)" and
C'subD: "P ⊢ C' ≼⇧* D"
by (fastforce dest!: conf_ClassD)
with wfprog m_D
obtain Ts' T' m' D'' mxs' mxl' ins' xt' where
m_C': "P ⊢ C' sees M': Ts'→T' = (mxs',mxl',ins',xt') in D''" and
T': "P ⊢ T' ≤ T" and
Ts': "P ⊢ Ts [≤] Ts'"
by (auto dest: sees_method_mono)
let ?loc' = "Addr a # rev (take n stk) @ replicate mxl' undefined"
let ?f' = "([], ?loc', D'', M', 0)"
let ?f = "(stk, loc, C, M, pc)"
from Addr obj m_C' ins σ' meth_C
have s': "σ' = (None, h, ?f' # ?f # frs)" by simp
from Ts n have [simp]: "size Ts = n"
by (auto dest: list_all2_lengthD simp: min_def)
with Ts' have [simp]: "size Ts' = n"
by (auto dest: list_all2_lengthD)
from m_C' wfprog
obtain mD'': "P ⊢ D'' sees M':Ts'→T'=(mxs',mxl',ins',xt') in D''"
by (fast dest: sees_method_idemp)
moreover
with wtprog
obtain start: "wt_start P D'' Ts' mxl' (Φ D'' M')" and ins': "ins' ≠ []"
by (auto dest: wt_jvm_prog_impl_wt_start)
then obtain LT⇩0 where LT⇩0: "Φ D'' M' ! 0 = Some ([], LT⇩0)"
by (clarsimp simp add: wt_start_def defs1 sup_state_opt_any_Some)
moreover
have "conf_f P h ([], LT⇩0) ins' ?f'"
proof -
let ?LT = "OK (Class D'') # (map OK Ts') @ (replicate mxl' Err)"
from stk have "P,h ⊢ take n stk [:≤] take n ST" ..
hence "P,h ⊢ rev (take n stk) [:≤] rev (take n ST)" by simp
also note Ts also note Ts' finally
have "P,h ⊢ rev (take n stk) [:≤⇩⊤] map OK Ts'" by simp
also
have "P,h ⊢ replicate mxl' undefined [:≤⇩⊤] replicate mxl' Err"
by simp
also from m_C' have "P ⊢ C' ≼⇧* D''" by (rule sees_method_decl_above)
with obj have "P,h ⊢ Addr a :≤ Class D''" by (simp add: conf_def)
ultimately
have "P,h ⊢ ?loc' [:≤⇩⊤] ?LT" by simp
also from start LT⇩0 have "P ⊢ … [≤⇩⊤] LT⇩0" by (simp add: wt_start_def)
finally have "P,h ⊢ ?loc' [:≤⇩⊤] LT⇩0" .
thus ?thesis using ins' by simp
qed
ultimately
have ?thesis using s' Φ_pc approx meth_C m_D T' ins D
by (fastforce dest: sees_method_fun [of _ C])
}
ultimately show ?thesis by blast
qed
declare list_all2_Cons2 [iff]
lemma Return_correct:
fixes σ' :: jvm_state
assumes wt_prog: "wf_jvm_prog⇘Φ⇙ P"
assumes meth: "P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C"
assumes ins: "ins ! pc = Return"
assumes wt: "P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M"
assumes s': "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
assumes correct: "P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√"
shows "P,Φ ⊢ σ'√"
proof -
from wt_prog
obtain wfmb where wf: "wf_prog wfmb P" by (simp add: wf_jvm_prog_phi_def)
from meth ins s'
have "frs = [] ⟹ ?thesis" by (simp add: correct_state_def)
moreover
{ fix f frs' assume frs': "frs = f#frs'"
moreover obtain stk' loc' C' M' pc' where
f: "f = (stk',loc',C',M',pc')" by (cases f)
moreover note meth ins s'
ultimately
have σ':
"σ' = (None,h,(hd stk#(drop (1+size Ts) stk'),loc',C',M',pc'+1)#frs')"
(is "σ' = (None,h,?f'#frs')")
by simp
from correct meth
obtain ST LT where
h_ok: "P ⊢ h √" and
Φ_pc: "Φ C M ! pc = Some (ST, LT)" and
frame: "conf_f P h (ST, LT) ins (stk,loc,C,M,pc)" and
frames: "conf_fs P h Φ M (size Ts) T frs"
by (auto dest: sees_method_fun simp add: correct_state_def)
from Φ_pc ins wt
obtain U ST⇩0 where "ST = U # ST⇩0" "P ⊢ U ≤ T"
by (simp add: wt_instr_def app_def) blast
with wf frame
have hd_stk: "P,h ⊢ hd stk :≤ T" by (auto simp add: conf_f_def)
from f frs' frames
obtain ST' LT' Ts'' T'' mxs' mxl⇩0' ins' xt' D Ts' T' m D' where
Φ': "Φ C' M' ! pc' = Some (ST', LT')" and
meth_C': "P ⊢ C' sees M':Ts''→T''=(mxs',mxl⇩0',ins',xt') in C'" and
ins': "ins' ! pc' = Invoke M (size Ts)" and
D: "ST' ! (size Ts) = Class D" and
meth_D: "P ⊢ D sees M: Ts'→T' = m in D'" and
T': "P ⊢ T ≤ T'" and
frame': "conf_f P h (ST',LT') ins' f" and
conf_fs: "conf_fs P h Φ M' (size Ts'') T'' frs'"
by clarsimp
from f frame' obtain
stk': "P,h ⊢ stk' [:≤] ST'" and
loc': "P,h ⊢ loc' [:≤⇩⊤] LT'" and
pc': "pc' < size ins'"
by (simp add: conf_f_def)
from wt_prog meth_C' pc'
have "P,T'',mxs',size ins',xt' ⊢ ins'!pc',pc' :: Φ C' M'"
by (rule wt_jvm_prog_impl_wt_instr)
with ins' Φ' D meth_D
obtain aTs ST'' LT'' where
Φ_suc: "Φ C' M' ! Suc pc' = Some (ST'', LT'')" and
less: "P ⊢ (T' # drop (size Ts+1) ST', LT') ≤⇩i (ST'', LT'')" and
suc_pc': "Suc pc' < size ins'"
by (clarsimp simp add: sup_state_opt_any_Some)
from hd_stk T' have hd_stk': "P,h ⊢ hd stk :≤ T'" ..
have frame'':
"conf_f P h (ST'',LT'') ins' ?f'"
proof -
from stk'
have "P,h ⊢ drop (1+size Ts) stk' [:≤] drop (1+size Ts) ST'" ..
moreover
with hd_stk' less
have "P,h ⊢ hd stk # drop (1+size Ts) stk' [:≤] ST''" by auto
moreover
from wf loc' less have "P,h ⊢ loc' [:≤⇩⊤] LT''" by auto
moreover note suc_pc'
ultimately show ?thesis by (simp add: conf_f_def)
qed
with σ' frs' f meth h_ok hd_stk Φ_suc frames meth_C' Φ'
have ?thesis by (fastforce dest: sees_method_fun [of _ C'])
}
ultimately
show ?thesis by (cases frs) blast+
qed
declare sup_state_opt_any_Some [iff]
declare not_Err_eq [iff]
lemma Load_correct:
"⟦ wf_prog wt P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins!pc = Load idx;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ P,Φ ⊢ σ'√"
by (fastforce dest: sees_method_fun [of _ C] elim!: confTs_confT_sup)
declare [[simproc del: list_to_set_comprehension]]
lemma Store_correct:
"⟦ wf_prog wt P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins!pc = Store idx;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ P,Φ ⊢ σ'√"
apply clarsimp
apply (drule (1) sees_method_fun)
apply clarsimp
apply (blast intro!: list_all2_update_cong)
done
lemma Push_correct:
"⟦ wf_prog wt P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins!pc = Push v;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ P,Φ ⊢ σ'√"
apply clarsimp
apply (drule (1) sees_method_fun)
apply clarsimp
apply (blast dest: typeof_lit_conf)
done
lemma Cast_conf2:
"⟦ wf_prog ok P; P,h ⊢ v :≤ T; is_refT T; cast_ok P C h v;
P ⊢ Class C ≤ T'; is_class P C⟧
⟹ P,h ⊢ v :≤ T'"
apply (unfold cast_ok_def is_refT_def)
apply (frule Class_widen)
apply (elim exE disjE)
apply simp
apply simp
apply simp
apply (clarsimp simp add: conf_def obj_ty_def)
apply (cases v)
apply (auto intro: rtrancl_trans)
done
lemma Checkcast_correct:
"⟦ wf_jvm_prog⇘Φ⇙ P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins!pc = Checkcast D;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√;
fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None ⟧
⟹ P,Φ ⊢ σ'√"
apply (clarsimp simp add: wf_jvm_prog_phi_def split: if_split_asm)
apply (drule (1) sees_method_fun)
apply (blast intro: Cast_conf2)
done
declare split_paired_All [simp del]
lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P
lemma Getfield_correct:
fixes σ' :: jvm_state
assumes wf: "wf_prog wt P"
assumes mC: "P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C"
assumes i: "ins!pc = Getfield F D"
assumes wt: "P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M"
assumes s': "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
assumes cf: "P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√"
assumes xc: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"
shows "P,Φ ⊢ σ'√"
proof -
from mC cf obtain ST LT where
"h√": "P ⊢ h √" and
Φ: "Φ C M ! pc = Some (ST,LT)" and
stk: "P,h ⊢ stk [:≤] ST" and loc: "P,h ⊢ loc [:≤⇩⊤] LT" and
pc: "pc < size ins" and
fs: "conf_fs P h Φ M (size Ts) T frs"
by (fastforce dest: sees_method_fun)
from i Φ wt obtain oT ST'' vT ST' LT' vT' where
oT: "P ⊢ oT ≤ Class D" and
ST: "ST = oT # ST''" and
F: "P ⊢ D sees F:vT in D" and
pc': "pc+1 < size ins" and
Φ': "Φ C M ! (pc+1) = Some (vT'#ST', LT')" and
ST': "P ⊢ ST'' [≤] ST'" and LT': "P ⊢ LT [≤⇩⊤] LT'" and
vT': "P ⊢ vT ≤ vT'"
by fastforce
from stk ST obtain ref stk' where
stk': "stk = ref#stk'" and
ref: "P,h ⊢ ref :≤ oT" and
ST'': "P,h ⊢ stk' [:≤] ST''"
by auto
from stk' i mC s' xc have "ref ≠ Null"
by (simp add: split_beta split:if_split_asm)
moreover from ref oT have "P,h ⊢ ref :≤ Class D" ..
ultimately obtain a D' fs where
a: "ref = Addr a" and h: "h a = Some (D', fs)" and D': "P ⊢ D' ≼⇧* D"
by (blast dest: non_npD)
from D' F have has_field: "P ⊢ D' has F:vT in D"
by (blast intro: has_field_mono has_visible_field)
moreover from "h√" h have "P,h ⊢ (D', fs) √" by (rule hconfD)
ultimately obtain v where v: "fs (F, D) = Some v" "P,h ⊢ v :≤ vT"
by (clarsimp simp add: oconf_def has_field_def)
(blast dest: has_fields_fun)
from a h i mC s' stk' v
have "σ' = (None, h, (v#stk',loc,C,M,pc+1)#frs)" by simp
moreover
from ST'' ST' have "P,h ⊢ stk' [:≤] ST'" ..
moreover
from v vT' have "P,h ⊢ v :≤ vT'" by blast
moreover
from loc LT' have "P,h ⊢ loc [:≤⇩⊤] LT'" ..
moreover
note "h√" mC Φ' pc' v fs
ultimately
show "P,Φ ⊢ σ' √" by fastforce
qed
lemma Putfield_correct:
fixes σ' :: jvm_state
assumes wf: "wf_prog wt P"
assumes mC: "P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C"
assumes i: "ins!pc = Putfield F D"
assumes wt: "P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M"
assumes s': "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
assumes cf: "P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√"
assumes xc: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"
shows "P,Φ ⊢ σ'√"
proof -
from mC cf obtain ST LT where
"h√": "P ⊢ h √" and
Φ: "Φ C M ! pc = Some (ST,LT)" and
stk: "P,h ⊢ stk [:≤] ST" and loc: "P,h ⊢ loc [:≤⇩⊤] LT" and
pc: "pc < size ins" and
fs: "conf_fs P h Φ M (size Ts) T frs"
by (fastforce dest: sees_method_fun)
from i Φ wt obtain vT vT' oT ST'' ST' LT' where
ST: "ST = vT # oT # ST''" and
field: "P ⊢ D sees F:vT' in D" and
oT: "P ⊢ oT ≤ Class D" and vT: "P ⊢ vT ≤ vT'" and
pc': "pc+1 < size ins" and
Φ': "Φ C M!(pc+1) = Some (ST',LT')" and
ST': "P ⊢ ST'' [≤] ST'" and LT': "P ⊢ LT [≤⇩⊤] LT'"
by clarsimp
from stk ST obtain v ref stk' where
stk': "stk = v#ref#stk'" and
v: "P,h ⊢ v :≤ vT" and
ref: "P,h ⊢ ref :≤ oT" and
ST'': "P,h ⊢ stk' [:≤] ST''"
by auto
from stk' i mC s' xc have "ref ≠ Null" by (auto simp add: split_beta)
moreover from ref oT have "P,h ⊢ ref :≤ Class D" ..
ultimately obtain a D' fs where
a: "ref = Addr a" and h: "h a = Some (D', fs)" and D': "P ⊢ D' ≼⇧* D"
by (blast dest: non_npD)
from v vT have vT': "P,h ⊢ v :≤ vT'" ..
from field D' have has_field: "P ⊢ D' has F:vT' in D"
by (blast intro: has_field_mono has_visible_field)
let ?h' = "h(a↦(D', fs((F, D)↦v)))" and ?f' = "(stk',loc,C,M,pc+1)"
from h have hext: "h ⊴ ?h'" by (rule hext_upd_obj)
from a h i mC s' stk'
have "σ' = (None, ?h', ?f'#frs)" by simp
moreover
from "h√" h have "P,h ⊢ (D',fs)√" by (rule hconfD)
with has_field vT' have "P,h ⊢ (D',fs((F, D)↦v))√" ..
with "h√" h have "P ⊢ ?h'√" by (rule hconf_upd_obj)
moreover
from ST'' ST' have "P,h ⊢ stk' [:≤] ST'" ..
from this hext have "P,?h' ⊢ stk' [:≤] ST'" by (rule confs_hext)
moreover
from loc LT' have "P,h ⊢ loc [:≤⇩⊤] LT'" ..
from this hext have "P,?h' ⊢ loc [:≤⇩⊤] LT'" by (rule confTs_hext)
moreover
from fs hext
have "conf_fs P ?h' Φ M (size Ts) T frs" by (rule conf_fs_hext)
moreover
note mC Φ' pc'
ultimately
show "P,Φ ⊢ σ' √" by fastforce
qed
lemma has_fields_b_fields:
"P ⊢ C has_fields FDTs ⟹ fields P C = FDTs"
apply (unfold fields_def)
apply (blast intro: the_equality has_fields_fun)
done
lemma oconf_blank [intro, simp]:
"⟦is_class P C; wf_prog wt P⟧ ⟹ P,h ⊢ blank P C √"
by (fastforce simp add: blank_def has_fields_b_fields oconf_init_fields
dest: wf_Fields_Ex)
lemma obj_ty_blank [iff]: "obj_ty (blank P C) = Class C"
by (simp add: blank_def)
lemma New_correct:
fixes σ' :: jvm_state
assumes wf: "wf_prog wt P"
assumes meth: "P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C"
assumes ins: "ins!pc = New X"
assumes wt: "P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M"
assumes exec: "Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs)"
assumes conf: "P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√"
assumes no_x: "fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None"
shows "P,Φ ⊢ σ'√"
proof -
from ins conf meth
obtain ST LT where
heap_ok: "P⊢ h√" and
Φ_pc: "Φ C M!pc = Some (ST,LT)" and
frame: "conf_f P h (ST,LT) ins (stk,loc,C,M,pc)" and
frames: "conf_fs P h Φ M (size Ts) T frs"
by (auto dest: sees_method_fun)
from Φ_pc ins wt
obtain ST' LT' where
is_class_X: "is_class P X" and
mxs: "size ST < mxs" and
suc_pc: "pc+1 < size ins" and
Φ_suc: "Φ C M!(pc+1) = Some (ST', LT')" and
less: "P ⊢ (Class X # ST, LT) ≤⇩i (ST', LT')"
by auto
from ins no_x obtain oref where new_Addr: "new_Addr h = Some oref" by auto
hence h: "h oref = None" by (rule new_Addr_SomeD)
with exec ins meth new_Addr have σ':
"σ' = (None, h(oref ↦ blank P X), (Addr oref#stk,loc,C,M,pc+1)#frs)"
(is "σ' = (None, ?h', ?f # frs)")
by simp
moreover
from wf h heap_ok is_class_X have h': "P ⊢ ?h' √"
by (auto intro: hconf_new)
moreover
from h frame less suc_pc wf
have "conf_f P ?h' (ST', LT') ins ?f"
apply (clarsimp simp add: fun_upd_apply conf_def blank_def split_beta)
apply (auto intro: confs_hext confTs_hext)
done
moreover
from h have "h ⊴ ?h'" by simp
with frames have "conf_fs P ?h' Φ M (size Ts) T frs" by (rule conf_fs_hext)
ultimately
show ?thesis using meth Φ_suc by fastforce
qed
lemma Goto_correct:
"⟦ wf_prog wt P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins ! pc = Goto branch;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ P,Φ ⊢ σ'√"
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
lemma IfFalse_correct:
"⟦ wf_prog wt P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins ! pc = IfFalse branch;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ P,Φ ⊢ σ'√"
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
lemma CmpEq_correct:
"⟦ wf_prog wt P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins ! pc = CmpEq;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ P,Φ ⊢ σ'√"
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
lemma Pop_correct:
"⟦ wf_prog wt P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins ! pc = Pop;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ P,Φ ⊢ σ'√"
apply clarsimp
apply (drule (1) sees_method_fun)
apply fastforce
done
lemma IAdd_correct:
"⟦ wf_prog wt P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins ! pc = IAdd;
P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ P,Φ ⊢ σ'√"
apply (clarsimp simp add: conf_def)
apply (drule (1) sees_method_fun)
apply fastforce
done
lemma Throw_correct:
"⟦ wf_prog wt P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
ins ! pc = Throw;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs) ;
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√;
fst (exec_instr (ins!pc) P h stk loc C M pc frs) = None ⟧
⟹ P,Φ ⊢ σ'√"
by simp
text ‹
The next theorem collects the results of the sections above,
i.e.~exception handling and the execution step for each
instruction. It states type safety for single step execution:
in welltyped programs, a conforming state is transformed
into another conforming state when one instruction is executed.
›
theorem instr_correct:
"⟦ wf_jvm_prog⇘Φ⇙ P;
P ⊢ C sees M:Ts→T=(mxs,mxl⇩0,ins,xt) in C;
Some σ' = exec (P, None, h, (stk,loc,C,M,pc)#frs);
P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√ ⟧
⟹ P,Φ ⊢ σ'√"
apply (subgoal_tac "P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M")
prefer 2
apply (erule wt_jvm_prog_impl_wt_instr, assumption)
apply clarsimp
apply (drule (1) sees_method_fun)
apply simp
apply (cases "fst (exec_instr (ins!pc) P h stk loc C M pc frs)")
prefer 2
apply (erule xcpt_correct, assumption+)
apply (frule wt_jvm_progD, erule exE)
apply (cases "ins!pc")
apply (rule Load_correct, assumption+)
apply (rule Store_correct, assumption+)
apply (rule Push_correct, assumption+)
apply (rule New_correct, assumption+)
apply (rule Getfield_correct, assumption+)
apply (rule Putfield_correct, assumption+)
apply (rule Checkcast_correct, assumption+)
apply (rule Invoke_correct, assumption+)
apply (rule Return_correct, assumption+)
apply (rule Pop_correct, assumption+)
apply (rule IAdd_correct, assumption+)
apply (rule Goto_correct, assumption+)
apply (rule CmpEq_correct, assumption+)
apply (rule IfFalse_correct, assumption+)
apply (rule Throw_correct, assumption+)
done
subsection ‹Main›
lemma correct_state_impl_Some_method:
"P,Φ ⊢ (None, h, (stk,loc,C,M,pc)#frs)√
⟹ ∃m Ts T. P ⊢ C sees M:Ts→T = m in C"
by fastforce
lemma BV_correct_1 [rule_format]:
"⋀σ. ⟦ wf_jvm_prog⇘Φ⇙ P; P,Φ ⊢ σ√⟧ ⟹ P ⊢ σ -jvm→⇩1 σ' ⟶ P,Φ ⊢ σ'√"
apply (simp only: split_tupled_all exec_1_iff)
apply (rename_tac xp h frs)
apply (case_tac xp)
apply (case_tac frs)
apply simp
apply (simp only: split_tupled_all)
apply hypsubst
apply (frule correct_state_impl_Some_method)
apply clarify
apply (rule instr_correct)
apply assumption+
apply (rule sym)
apply assumption+
apply (case_tac frs)
apply simp_all
done
theorem progress:
"⟦ xp=None; frs≠[] ⟧ ⟹ ∃σ'. P ⊢ (xp,h,frs) -jvm→⇩1 σ'"
by (clarsimp simp add: exec_1_iff neq_Nil_conv split_beta
simp del: split_paired_Ex)
lemma progress_conform:
"⟦wf_jvm_prog⇘Φ⇙ P; P,Φ ⊢ (xp,h,frs)√; xp=None; frs≠[]⟧
⟹ ∃σ'. P ⊢ (xp,h,frs) -jvm→⇩1 σ' ∧ P,Φ ⊢ σ'√"
apply (drule progress)
apply assumption
apply (fast intro: BV_correct_1)
done
theorem BV_correct [rule_format]:
"⟦ wf_jvm_prog⇘Φ⇙ P; P ⊢ σ -jvm→ σ' ⟧ ⟹ P,Φ ⊢ σ√ ⟶ P,Φ ⊢ σ'√"
apply (simp only: exec_all_def1)
apply (erule rtrancl_induct)
apply simp
apply clarify
apply (erule (2) BV_correct_1)
done
lemma hconf_start:
assumes wf: "wf_prog wf_mb P"
shows "P ⊢ (start_heap P) √"
apply (unfold hconf_def)
apply (simp add: preallocated_start)
apply (clarify)
apply (drule sym)
apply (unfold start_heap_def)
apply (insert wf)
apply (auto simp add: fun_upd_apply is_class_xcpt split: if_split_asm)
done
lemma BV_correct_initial:
shows "⟦ wf_jvm_prog⇘Φ⇙ P; P ⊢ C sees M:[]→T = m in C ⟧
⟹ P,Φ ⊢ start_state P C M √"
apply (cases m)
apply (unfold start_state_def)
apply (unfold correct_state_def)
apply (simp del: defs1)
apply (rule conjI)
apply (simp add: wf_jvm_prog_phi_def hconf_start)
apply (drule wt_jvm_prog_impl_wt_start, assumption+)
apply (unfold conf_f_def wt_start_def)
apply fastforce
done
declare [[simproc add: list_to_set_comprehension]]
theorem typesafe:
assumes welltyped: "wf_jvm_prog⇘Φ⇙ P"
assumes main_method: "P ⊢ C sees M:[]→T = m in C"
shows "P ⊢ start_state P C M -jvm→ σ ⟹ P,Φ ⊢ σ √"
proof -
from welltyped main_method
have "P,Φ ⊢ start_state P C M √" by (rule BV_correct_initial)
moreover
assume "P ⊢ start_state P C M -jvm→ σ"
ultimately
show "P,Φ ⊢ σ √" using welltyped by - (rule BV_correct)
qed
end
Theory BVNoTypeError
section ‹Welltyped Programs produce no Type Errors›
theory BVNoTypeError
imports "../JVM/JVMDefensive" BVSpecTypeSafe
begin
lemma has_methodI:
"P ⊢ C sees M:Ts→T = m in D ⟹ P ⊢ C has M"
by (unfold has_method_def) blast
text ‹
Some simple lemmas about the type testing functions of the
defensive JVM:
›
lemma typeof_NoneD [simp,dest]: "typeof v = Some x ⟹ ¬is_Addr v"
by (cases v) auto
lemma is_Ref_def2:
"is_Ref v = (v = Null ∨ (∃a. v = Addr a))"
by (cases v) (auto simp add: is_Ref_def)
lemma [iff]: "is_Ref Null" by (simp add: is_Ref_def2)
lemma is_RefI [intro, simp]: "P,h ⊢ v :≤ T ⟹ is_refT T ⟹ is_Ref v"
apply (cases T)
apply (auto simp add: is_refT_def is_Ref_def dest: conf_ClassD)
done
lemma is_IntgI [intro, simp]: "P,h ⊢ v :≤ Integer ⟹ is_Intg v"
apply (unfold conf_def)
apply auto
done
lemma is_BoolI [intro, simp]: "P,h ⊢ v :≤ Boolean ⟹ is_Bool v"
apply (unfold conf_def)
apply auto
done
declare defs1 [simp del]
lemma wt_jvm_prog_states:
"⟦ wf_jvm_prog⇘Φ⇙ P; P ⊢ C sees M: Ts→T = (mxs, mxl, ins, et) in C;
Φ C M ! pc = τ; pc < size ins ⟧
⟹ OK τ ∈ states P mxs (1+size Ts+mxl)"
apply (unfold wf_jvm_prog_phi_def)
apply (drule (1) sees_wf_mdecl)
apply (simp add: wf_mdecl_def wt_method_def check_types_def)
apply (blast intro: nth_in)
done
text ‹
The main theorem: welltyped programs do not produce type errors if they
are started in a conformant state.
›
theorem no_type_error:
fixes σ :: jvm_state
assumes welltyped: "wf_jvm_prog⇘Φ⇙ P" and conforms: "P,Φ ⊢ σ √"
shows "exec_d P σ ≠ TypeError"
proof -
from welltyped obtain mb where wf: "wf_prog mb P" by (fast dest: wt_jvm_progD)
obtain xcp h frs where s [simp]: "σ = (xcp, h, frs)" by (cases σ)
from conforms have "xcp ≠ None ∨ frs = [] ⟹ check P σ"
by (unfold correct_state_def check_def) auto
moreover {
assume "¬(xcp ≠ None ∨ frs = [])"
then obtain stk reg C M pc frs' where
xcp [simp]: "xcp = None" and
frs [simp]: "frs = (stk,reg,C,M,pc)#frs'"
by (clarsimp simp add: neq_Nil_conv)
from conforms obtain ST LT Ts T mxs mxl ins xt where
hconf: "P ⊢ h √" and
meth: "P ⊢ C sees M:Ts→T = (mxs, mxl, ins, xt) in C" and
Φ: "Φ C M ! pc = Some (ST,LT)" and
frame: "conf_f P h (ST,LT) ins (stk,reg,C,M,pc)" and
frames: "conf_fs P h Φ M (size Ts) T frs'"
by (fastforce simp add: correct_state_def dest: sees_method_fun)
from frame obtain
stk: "P,h ⊢ stk [:≤] ST" and
reg: "P,h ⊢ reg [:≤⇩⊤] LT" and
pc: "pc < size ins"
by (simp add: conf_f_def)
from welltyped meth Φ pc
have "OK (Some (ST, LT)) ∈ states P mxs (1+size Ts+mxl)"
by (rule wt_jvm_prog_states)
hence "size ST ≤ mxs" by (auto simp add: JVM_states_unfold)
with stk have mxs: "size stk ≤ mxs"
by (auto dest: list_all2_lengthD)
from welltyped meth pc
have "P,T,mxs,size ins,xt ⊢ ins!pc,pc :: Φ C M"
by (rule wt_jvm_prog_impl_wt_instr)
hence app⇩0: "app (ins!pc) P mxs T pc (size ins) xt (Φ C M!pc) "
by (simp add: wt_instr_def)
with Φ have eff:
"∀(pc',s')∈set (eff (ins ! pc) P pc xt (Φ C M ! pc)). pc' < size ins"
by (unfold app_def) simp
from app⇩0 Φ have app:
"xcpt_app (ins!pc) P pc mxs xt (ST,LT) ∧ app⇩i (ins!pc, P, pc, mxs, T, (ST,LT))"
by (clarsimp simp add: app_def)
with eff stk reg
have "check_instr (ins!pc) P h stk reg C M pc frs'"
proof (cases "ins!pc")
case (Getfield F C)
with app stk reg Φ obtain v vT stk' where
field: "P ⊢ C sees F:vT in C" and
stk: "stk = v # stk'" and
conf: "P,h ⊢ v :≤ Class C"
by auto
from conf have is_Ref: "is_Ref v" by auto
moreover {
assume "v ≠ Null"
with conf field is_Ref wf
have "∃D vs. h (the_Addr v) = Some (D,vs) ∧ P ⊢ D ≼⇧* C"
by (auto dest!: non_npD)
}
ultimately show ?thesis using Getfield field stk hconf
apply clarsimp
apply (rule conjI, fastforce)
apply clarsimp
apply (drule has_visible_field)
apply (drule (1) has_field_mono)
apply (drule (1) hconfD)
apply (unfold oconf_def has_field_def)
apply clarsimp
apply (fastforce dest: has_fields_fun)
done
next
case (Putfield F C)
with app stk reg Φ obtain v ref vT stk' where
field: "P ⊢ C sees F:vT in C" and
stk: "stk = v # ref # stk'" and
confv: "P,h ⊢ v :≤ vT" and
confr: "P,h ⊢ ref :≤ Class C"
by fastforce
from confr have is_Ref: "is_Ref ref" by simp
moreover {
assume "ref ≠ Null"
with confr field is_Ref wf
have "∃D vs. h (the_Addr ref) = Some (D,vs) ∧ P ⊢ D ≼⇧* C"
by (auto dest: non_npD)
}
ultimately show ?thesis using Putfield field stk confv by fastforce
next
case (Invoke M' n)
with app have n: "n < size ST" by simp
from stk have [simp]: "size stk = size ST" by (rule list_all2_lengthD)
{ assume "stk!n = Null" with n Invoke have ?thesis by simp }
moreover {
assume "ST!n = NT"
with n stk have "stk!n = Null" by (auto simp: list_all2_conv_all_nth)
with n Invoke have ?thesis by simp
}
moreover {
assume Null: "stk!n ≠ Null" and NT: "ST!n ≠ NT"
from NT app Invoke
obtain D D' Ts T m where
D: "ST!n = Class D" and
M': "P ⊢ D sees M': Ts→T = m in D'" and
Ts: "P ⊢ rev (take n ST) [≤] Ts"
by auto
from D stk n have "P,h ⊢ stk!n :≤ Class D"
by (auto simp: list_all2_conv_all_nth)
with Null obtain a C' fs where
[simp]: "stk!n = Addr a" "h a = Some (C',fs)" and
"P ⊢ C' ≼⇧* D"
by (fastforce dest!: conf_ClassD)
with M' wf obtain m' Ts' T' D'' where
C': "P ⊢ C' sees M': Ts'→T' = m' in D''" and
Ts': "P ⊢ Ts [≤] Ts'"
by (auto dest!: sees_method_mono)
from stk have "P,h ⊢ take n stk [:≤] take n ST" ..
hence "P,h ⊢ rev (take n stk) [:≤] rev (take n ST)" ..
also note Ts also note Ts'
finally have "P,h ⊢ rev (take n stk) [:≤] Ts'" .
with Invoke Null n C'
have ?thesis by (auto simp add: is_Ref_def2 has_methodI)
}
ultimately show ?thesis by blast
next
case Return with stk app Φ meth frames
show ?thesis by (auto simp add: has_methodI)
qed (auto simp add: list_all2_lengthD)
hence "check P σ" using meth pc mxs by (simp add: check_def has_methodI)
} ultimately
have "check P σ" by blast
thus "exec_d P σ ≠ TypeError" ..
qed
text ‹
The theorem above tells us that, in welltyped programs, the
defensive machine reaches the same result as the aggressive
one (after arbitrarily many steps).
›
theorem welltyped_aggressive_imp_defensive:
"wf_jvm_prog⇘Φ⇙ P ⟹ P,Φ ⊢ σ √ ⟹ P ⊢ σ -jvm→ σ'
⟹ P ⊢ (Normal σ) -jvmd→ (Normal σ')"
apply (simp only: exec_all_def)
apply (erule rtrancl_induct)
apply (simp add: exec_all_d_def1)
apply simp
apply (simp only: exec_all_def [symmetric])
apply (frule BV_correct, assumption+)
apply (drule no_type_error, assumption, drule no_type_error_commutes, simp)
apply (simp add: exec_all_d_def1)
apply (rule rtrancl_trans, assumption)
apply (drule exec_1_d_NormalI)
apply auto
done
text ‹
As corollary we get that the aggressive and the defensive machine
are equivalent for welltyped programs (if started in a conformant
state or in the canonical start state)
›
corollary welltyped_commutes:
fixes σ :: jvm_state
assumes wf: "wf_jvm_prog⇘Φ⇙ P" and conforms: "P,Φ ⊢ σ √"
shows "P ⊢ (Normal σ) -jvmd→ (Normal σ') = P ⊢ σ -jvm→ σ'"
apply rule
apply (erule defensive_imp_aggressive)
apply (erule welltyped_aggressive_imp_defensive [OF wf conforms])
done
corollary welltyped_initial_commutes:
assumes wf: "wf_jvm_prog P"
assumes meth: "P ⊢ C sees M:[]→T = b in C"
defines start: "σ ≡ start_state P C M"
shows "P ⊢ (Normal σ) -jvmd→ (Normal σ') = P ⊢ σ -jvm→ σ'"
proof -
from wf obtain Φ where wf': "wf_jvm_prog⇘Φ⇙ P" by (auto simp: wf_jvm_prog_def)
from this meth have "P,Φ ⊢ σ √" unfolding start by (rule BV_correct_initial)
with wf' show ?thesis by (rule welltyped_commutes)
qed
lemma not_TypeError_eq [iff]:
"x ≠ TypeError = (∃t. x = Normal t)"
by (cases x) auto
locale cnf =
fixes P and Φ and σ
assumes wf: "wf_jvm_prog⇘Φ⇙ P"
assumes cnf: "correct_state P Φ σ"
theorem (in cnf) no_type_errors:
"P ⊢ (Normal σ) -jvmd→ σ' ⟹ σ' ≠ TypeError"
apply (unfold exec_all_d_def1)
apply (erule rtrancl_induct)
apply simp
apply (fold exec_all_d_def1)
apply (insert cnf wf)
apply clarsimp
apply (drule defensive_imp_aggressive)
apply (frule (2) BV_correct)
apply (drule (1) no_type_error) back
apply (auto simp add: exec_1_d_eq)
done
locale start =
fixes P and C and M and σ and T and b
assumes wf: "wf_jvm_prog P"
assumes sees: "P ⊢ C sees M:[]→T = b in C"
defines "σ ≡ Normal (start_state P C M)"
corollary (in start) bv_no_type_error:
shows "P ⊢ σ -jvmd→ σ' ⟹ σ' ≠ TypeError"
proof -
from wf obtain Φ where "wf_jvm_prog⇘Φ⇙ P" by (auto simp: wf_jvm_prog_def)
moreover
with sees have "correct_state P Φ (start_state P C M)"
by - (rule BV_correct_initial)
ultimately have "cnf P Φ (start_state P C M)" by (rule cnf.intro)
moreover assume "P ⊢ σ -jvmd→ σ'"
ultimately show ?thesis by (unfold σ_def) (rule cnf.no_type_errors)
qed
end
Theory BVExample
section ‹Example Welltypings \label{sec:BVExample}›
theory BVExample
imports "../JVM/JVMListExample" BVSpecTypeSafe BVExec
"HOL-Library.Code_Target_Numeral"
begin
text ‹
This theory shows type correctness of the example program in section
\ref{sec:JVMListExample} (p. \pageref{sec:JVMListExample}) by
explicitly providing a welltyping. It also shows that the start
state of the program conforms to the welltyping; hence type safe
execution is guaranteed.
›
subsection "Setup"
lemma distinct_classes':
"list_name ≠ test_name"
"list_name ≠ Object"
"list_name ≠ ClassCast"
"list_name ≠ OutOfMemory"
"list_name ≠ NullPointer"
"test_name ≠ Object"
"test_name ≠ OutOfMemory"
"test_name ≠ ClassCast"
"test_name ≠ NullPointer"
"ClassCast ≠ NullPointer"
"ClassCast ≠ Object"
"NullPointer ≠ Object"
"OutOfMemory ≠ ClassCast"
"OutOfMemory ≠ NullPointer"
"OutOfMemory ≠ Object"
by (simp_all add: list_name_def test_name_def Object_def NullPointer_def
OutOfMemory_def ClassCast_def)
lemmas distinct_classes = distinct_classes' distinct_classes' [symmetric]
lemma distinct_fields:
"val_name ≠ next_name"
"next_name ≠ val_name"
by (simp_all add: val_name_def next_name_def)
text ‹Abbreviations for definitions we will have to use often in the
proofs below:›
lemmas system_defs = SystemClasses_def ObjectC_def NullPointerC_def
OutOfMemoryC_def ClassCastC_def
lemmas class_defs = list_class_def test_class_def
text ‹These auxiliary proofs are for efficiency: class lookup,
subclass relation, method and field lookup are computed only once:
›
lemma class_Object [simp]:
"class E Object = Some (undefined, [],[])"
by (simp add: class_def system_defs E_def)
lemma class_NullPointer [simp]:
"class E NullPointer = Some (Object, [], [])"
by (simp add: class_def system_defs E_def distinct_classes)
lemma class_OutOfMemory [simp]:
"class E OutOfMemory = Some (Object, [], [])"
by (simp add: class_def system_defs E_def distinct_classes)
lemma class_ClassCast [simp]:
"class E ClassCast = Some (Object, [], [])"
by (simp add: class_def system_defs E_def distinct_classes)
lemma class_list [simp]:
"class E list_name = Some list_class"
by (simp add: class_def system_defs E_def distinct_classes)
lemma class_test [simp]:
"class E test_name = Some test_class"
by (simp add: class_def system_defs E_def distinct_classes)
lemma E_classes [simp]:
"{C. is_class E C} = {list_name, test_name, NullPointer,
ClassCast, OutOfMemory, Object}"
by (auto simp add: is_class_def class_def system_defs E_def class_defs)
text ‹The subclass releation spelled out:›
lemma subcls1:
"subcls1 E = {(list_name,Object), (test_name,Object), (NullPointer, Object),
(ClassCast, Object), (OutOfMemory, Object)}"
apply (simp add: subcls1_def2)
apply (simp add: class_defs system_defs E_def class_def)
apply (auto simp: distinct_classes split!: if_splits)
done
text ‹The subclass relation is acyclic; hence its converse is well founded:›
lemma notin_rtrancl:
"(a,b) ∈ r⇧* ⟹ a ≠ b ⟹ (⋀y. (a,y) ∉ r) ⟹ False"
by (auto elim: converse_rtranclE)
lemma acyclic_subcls1_E: "acyclic (subcls1 E)"
apply (rule acyclicI)
apply (simp add: subcls1)
apply (auto dest!: tranclD)
apply (auto elim!: notin_rtrancl simp add: distinct_classes)
done
lemma wf_subcls1_E: "wf ((subcls1 E)¯)"
apply (rule finite_acyclic_wf_converse)
apply (simp add: subcls1)
apply (rule acyclic_subcls1_E)
done
text ‹Method and field lookup:›
lemma method_append [simp]:
"method E list_name append_name =
(list_name, [Class list_name], Void, 3, 0, append_ins, [(1, 2, NullPointer, 7, 0)])"
apply (insert class_list)
apply (unfold list_class_def)
apply (fastforce simp add: Method_def distinct_classes intro: method_def2 Methods.intros)
done
lemma method_makelist [simp]:
"method E test_name makelist_name =
(test_name, [], Void, 3, 2, make_list_ins, [])"
apply (insert class_test)
apply (unfold test_class_def)
apply (fastforce simp add: Method_def distinct_classes intro: method_def2 Methods.intros)
done
lemma field_val [simp]:
"field E list_name val_name = (list_name, Integer)"
apply (insert class_list)
apply (unfold list_class_def)
apply (fastforce simp add: sees_field_def distinct_classes intro: field_def2 Fields.intros)
done
lemma field_next [simp]:
"field E list_name next_name = (list_name, Class list_name)"
apply (insert class_list)
apply (unfold list_class_def)
apply (fastforce simp add: distinct_fields sees_field_def distinct_classes intro: field_def2 Fields.intros)
done
lemma [simp]: "fields E Object = []"
by (fastforce intro: fields_def2 Fields.intros)
lemma [simp]: "fields E NullPointer = []"
by (fastforce simp add: distinct_classes intro: fields_def2 Fields.intros)
lemma [simp]: "fields E ClassCast = []"
by (fastforce simp add: distinct_classes intro: fields_def2 Fields.intros)
lemma [simp]: "fields E OutOfMemory = []"
by (fastforce simp add: distinct_classes intro: fields_def2 Fields.intros)
lemma [simp]: "fields E test_name = []"
apply (insert class_test)
apply (unfold test_class_def)
apply (fastforce simp add: distinct_classes intro: fields_def2 Fields.intros)
done
lemmas [simp] = is_class_def
subsection "Program structure"
text ‹
The program is structurally wellformed:
›
lemma wf_struct:
"wf_prog (λG C mb. True) E" (is "wf_prog ?mb E")
proof -
have "distinct_fst E"
by (simp add: system_defs E_def class_defs distinct_classes)
moreover
have "set SystemClasses ⊆ set E" by (simp add: system_defs E_def)
hence "wf_syscls E" by (rule wf_syscls)
moreover
have "wf_cdecl ?mb E ObjectC" by (simp add: wf_cdecl_def ObjectC_def)
moreover
have "wf_cdecl ?mb E NullPointerC"
by (auto elim: notin_rtrancl
simp add: wf_cdecl_def distinct_classes NullPointerC_def subcls1)
moreover
have "wf_cdecl ?mb E ClassCastC"
by (auto elim: notin_rtrancl
simp add: wf_cdecl_def distinct_classes ClassCastC_def subcls1)
moreover
have "wf_cdecl ?mb E OutOfMemoryC"
by (auto elim: notin_rtrancl
simp add: wf_cdecl_def distinct_classes OutOfMemoryC_def subcls1)
moreover
have "wf_cdecl ?mb E (list_name, list_class)"
apply (auto elim!: notin_rtrancl
simp add: wf_cdecl_def wf_fdecl_def list_class_def
wf_mdecl_def subcls1)
apply (auto simp add: distinct_classes distinct_fields Method_def elim: Methods.cases)
done
moreover
have "wf_cdecl ?mb E (test_name, test_class)"
apply (auto elim!: notin_rtrancl
simp add: wf_cdecl_def wf_fdecl_def test_class_def
wf_mdecl_def subcls1)
apply (auto simp add: distinct_classes distinct_fields Method_def elim: Methods.cases)
done
ultimately
show ?thesis by (simp add: wf_prog_def E_def SystemClasses_def)
qed
subsection "Welltypings"
text ‹
We show welltypings of the methods @{term append_name} in class @{term list_name},
and @{term makelist_name} in class @{term test_name}:
›
lemmas eff_simps [simp] = eff_def norm_eff_def xcpt_eff_def
definition phi_append :: ty⇩m ("φ⇩a")
where
"φ⇩a ≡ map (λ(x,y). Some (x, map OK y)) [
( [], [Class list_name, Class list_name]),
( [Class list_name], [Class list_name, Class list_name]),
( [Class list_name], [Class list_name, Class list_name]),
( [Class list_name, Class list_name], [Class list_name, Class list_name]),
( [Class list_name, Class list_name], [Class list_name, Class list_name]),
([NT, Class list_name, Class list_name], [Class list_name, Class list_name]),
( [Boolean, Class list_name], [Class list_name, Class list_name]),
( [Class Object], [Class list_name, Class list_name]),
( [], [Class list_name, Class list_name]),
( [Class list_name], [Class list_name, Class list_name]),
( [Class list_name, Class list_name], [Class list_name, Class list_name]),
( [], [Class list_name, Class list_name]),
( [Void], [Class list_name, Class list_name]),
( [Class list_name], [Class list_name, Class list_name]),
( [Class list_name, Class list_name], [Class list_name, Class list_name]),
( [Void], [Class list_name, Class list_name])]"
text ‹
The next definition and three proof rules implement an algorithm to
enumarate natural numbers. The command ‹apply (elim pc_end pc_next pc_0›
transforms a goal of the form
@{prop [display] "pc < n ⟹ P pc"}
into a series of goals
@{prop [display] "P 0"}
@{prop [display] "P (Suc 0)"}
‹…›
@{prop [display] "P n"}
›
definition intervall :: "nat ⇒ nat ⇒ nat ⇒ bool" ("_ ∈ [_, _')")
where
"x ∈ [a, b) ≡ a ≤ x ∧ x < b"
lemma pc_0: "x < n ⟹ (x ∈ [0, n) ⟹ P x) ⟹ P x"
by (simp add: intervall_def)
lemma pc_next: "x ∈ [n0, n) ⟹ P n0 ⟹ (x ∈ [Suc n0, n) ⟹ P x) ⟹ P x"
apply (cases "x=n0")
apply (auto simp add: intervall_def)
done
lemma pc_end: "x ∈ [n,n) ⟹ P x"
by (unfold intervall_def) arith
lemma types_append [simp]: "check_types E 3 (Suc (Suc 0)) (map OK φ⇩a)"
by (auto simp add: check_types_def phi_append_def JVM_states_unfold)
lemma wt_append [simp]:
"wt_method E list_name [Class list_name] Void 3 0 append_ins
[(Suc 0, 2, NullPointer, 7, 0)] φ⇩a"
apply (simp add: wt_method_def wt_start_def wt_instr_def)
apply (simp add: append_ins_def phi_append_def)
apply clarify
apply (drule sym)
apply (erule_tac P="x = y" for x y in rev_mp)
apply (elim pc_end pc_next pc_0)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add: matches_ex_entry_def subcls1
relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
distinct_classes distinct_fields intro: Fields.intros)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add:
relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
distinct_classes distinct_fields intro: Fields.intros)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add: relevant_entries_def is_relevant_entry_def subcls1)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add:
relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
distinct_classes distinct_fields intro: Fields.intros)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add:
relevant_entries_def is_relevant_entry_def list_class_def
distinct_classes Method_def intro: Methods.intros)
apply (simp add: relevant_entries_def is_relevant_entry_def)
done
text ‹Some abbreviations for readability›
abbreviation "Clist == Class list_name"
abbreviation "Ctest == Class test_name"
definition phi_makelist :: ty⇩m ("φ⇩m")
where
"φ⇩m ≡ map (λ(x,y). Some (x, y)) [
( [], [OK Ctest, Err , Err ]),
( [Clist], [OK Ctest, Err , Err ]),
( [], [OK Clist, Err , Err ]),
( [Clist], [OK Clist, Err , Err ]),
( [Integer, Clist], [OK Clist, Err , Err ]),
( [], [OK Clist, Err , Err ]),
( [Clist], [OK Clist, Err , Err ]),
( [], [OK Clist, OK Clist, Err ]),
( [Clist], [OK Clist, OK Clist, Err ]),
( [Integer, Clist], [OK Clist, OK Clist, Err ]),
( [], [OK Clist, OK Clist, Err ]),
( [Clist], [OK Clist, OK Clist, Err ]),
( [], [OK Clist, OK Clist, OK Clist]),
( [Clist], [OK Clist, OK Clist, OK Clist]),
( [Integer, Clist], [OK Clist, OK Clist, OK Clist]),
( [], [OK Clist, OK Clist, OK Clist]),
( [Clist], [OK Clist, OK Clist, OK Clist]),
( [Clist, Clist], [OK Clist, OK Clist, OK Clist]),
( [Void], [OK Clist, OK Clist, OK Clist]),
( [], [OK Clist, OK Clist, OK Clist]),
( [Clist], [OK Clist, OK Clist, OK Clist]),
( [Clist, Clist], [OK Clist, OK Clist, OK Clist]),
( [Void], [OK Clist, OK Clist, OK Clist])]"
lemma types_makelist [simp]: "check_types E 3 (Suc (Suc (Suc 0))) (map OK φ⇩m)"
by (auto simp add: check_types_def phi_makelist_def JVM_states_unfold)
lemma wt_makelist [simp]:
"wt_method E test_name [] Void 3 2 make_list_ins [] φ⇩m"
apply (simp add: wt_method_def)
apply (unfold make_list_ins_def phi_makelist_def)
apply (simp add: wt_start_def eval_nat_numeral)
apply (simp add: wt_instr_def)
apply clarify
apply (drule sym)
apply (erule_tac P="x = y" for x y in rev_mp)
apply (elim pc_end pc_next pc_0)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add:
relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
distinct_classes intro: Fields.intros)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add:
relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
distinct_classes intro: Fields.intros)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add:
relevant_entries_def is_relevant_entry_def sees_field_def list_class_def
distinct_classes intro: Fields.intros)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add:
relevant_entries_def is_relevant_entry_def list_class_def
distinct_classes Method_def intro: Methods.intros)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (simp add: relevant_entries_def is_relevant_entry_def)
apply (fastforce simp add:
relevant_entries_def is_relevant_entry_def list_class_def
distinct_classes Method_def intro: Methods.intros)
apply (simp add: relevant_entries_def is_relevant_entry_def)
done
lemma wf_md'E:
"⟦ wf_prog wf_md P;
⋀C S fs ms m.⟦(C,S,fs,ms) ∈ set P; m ∈ set ms⟧ ⟹ wf_md' P C m ⟧
⟹ wf_prog wf_md' P"
apply (simp add: wf_prog_def)
apply auto
apply (simp add: wf_cdecl_def wf_mdecl_def)
apply fastforce
done
text ‹The whole program is welltyped:›
definition Phi :: ty⇩P ("Φ")
where
"Φ C mn ≡ if C = test_name ∧ mn = makelist_name then φ⇩m else
if C = list_name ∧ mn = append_name then φ⇩a else []"
lemma wf_prog:
"wf_jvm_prog⇘Φ⇙ E"
apply (unfold wf_jvm_prog_phi_def)
apply (rule wf_md'E [OF wf_struct])
apply (simp add: E_def)
apply clarify
apply (fold E_def)
apply (simp add: system_defs class_defs Phi_def)
apply auto
apply (simp add: distinct_classes)
done
subsection "Conformance"
text ‹Execution of the program will be typesafe, because its
start state conforms to the welltyping:›
lemma "E,Φ ⊢ start_state E test_name makelist_name √"
apply (rule BV_correct_initial)
apply (rule wf_prog)
apply (fastforce simp add: test_class_def distinct_classes Method_def intro: Methods.intros)
done
subsection "Example for code generation: inferring method types"
definition test_kil :: "jvm_prog ⇒ cname ⇒ ty list ⇒ ty ⇒ nat ⇒ nat ⇒
ex_table ⇒ instr list ⇒ ty⇩i' err list"
where
"test_kil G C pTs rT mxs mxl et instr ≡
(let first = Some ([],(OK (Class C))#(map OK pTs)@(replicate mxl Err));
start = OK first#(replicate (size instr - 1) (OK None))
in kiljvm G mxs (1+size pTs+mxl) rT instr et start)"
lemma [code]:
"unstables r step ss =
fold (λp A. if ¬stable r step ss p then insert p A else A) [0..<size ss] {}"
proof -
have "unstables r step ss = (UN p:{..<size ss}. if ¬stable r step ss p then {p} else {})"
apply (unfold unstables_def)
apply (rule equalityI)
apply (rule subsetI)
apply (erule CollectE)
apply (erule conjE)
apply (rule UN_I)
apply simp
apply simp
apply (rule subsetI)
apply (erule UN_E)
apply (case_tac "¬ stable r step ss p")
apply simp+
done
also have "⋀f. (UN p:{..<size ss}. f p) = Union (set (map f [0..<size ss]))" by auto
also note Sup_set_fold also note fold_map
also have "(∪) ∘ (λp. if ¬ stable r step ss p then {p} else {}) =
(λp A. if ¬stable r step ss p then insert p A else A)"
by(auto simp add: fun_eq_iff)
finally show ?thesis .
qed
definition some_elem :: "'a set ⇒ 'a" where [code del]:
"some_elem = (%S. SOME x. x : S)"
code_printing
constant some_elem ⇀ (SML) "(case/ _ of/ Set/ xs/ =>/ hd/ xs)"
text ‹This code setup is just a demonstration and \emph{not} sound!›
notepad begin
have "some_elem (set [False, True]) = False" by eval
moreover have "some_elem (set [True, False]) = True" by eval
ultimately have False by (simp add: some_elem_def)
end
lemma [code]:
"iter f step ss w = while (λ(ss, w). ¬ Set.is_empty w)
(λ(ss, w).
let p = some_elem w in propa f (step p (ss ! p)) ss (w - {p}))
(ss, w)"
unfolding iter_def Set.is_empty_def some_elem_def ..
lemma JVM_sup_unfold [code]:
"JVM_SemiType.sup S m n = lift2 (Opt.sup
(Product.sup (Listn.sup (SemiType.sup S))
(λx y. OK (map2 (lift2 (SemiType.sup S)) x y))))"
apply (unfold JVM_SemiType.sup_def JVM_SemiType.sl_def Opt.esl_def Err.sl_def
stk_esl_def loc_sl_def Product.esl_def
Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
by simp
lemmas [code] = SemiType.sup_def [unfolded exec_lub_def] JVM_le_unfold
lemmas [code] = lesub_def plussub_def
lemma [code]:
"is_refT T = (case T of NT ⇒ True | Class C ⇒ True | _ ⇒ False)"
by (simp add: is_refT_def split: ty.split)
declare app⇩i.simps [code]
lemma [code]:
"app⇩i (Getfield F C, P, pc, mxs, T⇩r, (T#ST, LT)) =
Predicate.holds (Predicate.bind (sees_field_i_i_i_o_i P C F C) (λT⇩f. if P ⊢ T ≤ Class C then Predicate.single () else bot))"
by(auto simp add: Predicate.holds_eq intro: sees_field_i_i_i_o_iI elim: sees_field_i_i_i_o_iE)
lemma [code]:
"app⇩i (Putfield F C, P, pc, mxs, T⇩r, (T⇩1#T⇩2#ST, LT)) =
Predicate.holds (Predicate.bind (sees_field_i_i_i_o_i P C F C) (λT⇩f. if P ⊢ T⇩2 ≤ (Class C) ∧ P ⊢ T⇩1 ≤ T⇩f then Predicate.single () else bot))"
by(auto simp add: Predicate.holds_eq simp del: eval_bind split: if_split_asm elim!: sees_field_i_i_i_o_iE Predicate.bindE intro: Predicate.bindI sees_field_i_i_i_o_iI)
lemma [code]:
"app⇩i (Invoke M n, P, pc, mxs, T⇩r, (ST,LT)) =
(n < length ST ∧
(ST!n ≠ NT ⟶
(case ST!n of
Class C ⇒ Predicate.holds (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (λ(Ts, T, m, D). if P ⊢ rev (take n ST) [≤] Ts then Predicate.single () else bot))
| _ ⇒ False)))"
by (fastforce simp add: Predicate.holds_eq simp del: eval_bind split: ty.split_asm if_split_asm intro: bindI Method_i_i_i_o_o_o_oI elim!: bindE Method_i_i_i_o_o_o_oE)
lemmas [code] =
SemiType.sup_def [unfolded exec_lub_def]
widen.equation
is_relevant_class.simps
definition test1 where
"test1 = test_kil E list_name [Class list_name] Void 3 0
[(Suc 0, 2, NullPointer, 7, 0)] append_ins"
definition test2 where
"test2 = test_kil E test_name [] Void 3 2 [] make_list_ins"
definition test3 where "test3 = φ⇩a"
definition test4 where "test4 = φ⇩m"
ML_val ‹
if @{code test1} = @{code map} @{code OK} @{code test3} then () else error "wrong result";
if @{code test2} = @{code map} @{code OK} @{code test4} then () else error "wrong result"
›
end
Theory J1
chapter ‹Compilation \label{cha:comp}›
section ‹An Intermediate Language›
theory J1 imports "../J/BigStep" begin
type_synonym expr⇩1 = "nat exp"
type_synonym J⇩1_prog = "expr⇩1 prog"
type_synonym state⇩1 = "heap × (val list)"
primrec
max_vars :: "'a exp ⇒ nat"
and max_varss :: "'a exp list ⇒ nat"
where
"max_vars(new C) = 0"
| "max_vars(Cast C e) = max_vars e"
| "max_vars(Val v) = 0"
| "max_vars(e⇩1 «bop» e⇩2) = max (max_vars e⇩1) (max_vars e⇩2)"
| "max_vars(Var V) = 0"
| "max_vars(V:=e) = max_vars e"
| "max_vars(e∙F{D}) = max_vars e"
| "max_vars(FAss e⇩1 F D e⇩2) = max (max_vars e⇩1) (max_vars e⇩2)"
| "max_vars(e∙M(es)) = max (max_vars e) (max_varss es)"
| "max_vars({V:T; e}) = max_vars e + 1"
| "max_vars(e⇩1;;e⇩2) = max (max_vars e⇩1) (max_vars e⇩2)"
| "max_vars(if (e) e⇩1 else e⇩2) =
max (max_vars e) (max (max_vars e⇩1) (max_vars e⇩2))"
| "max_vars(while (b) e) = max (max_vars b) (max_vars e)"
| "max_vars(throw e) = max_vars e"
| "max_vars(try e⇩1 catch(C V) e⇩2) = max (max_vars e⇩1) (max_vars e⇩2 + 1)"
| "max_varss [] = 0"
| "max_varss (e#es) = max (max_vars e) (max_varss es)"
inductive
eval⇩1 :: "J⇩1_prog ⇒ expr⇩1 ⇒ state⇩1 ⇒ expr⇩1 ⇒ state⇩1 ⇒ bool"
("_ ⊢⇩1 ((1⟨_,/_⟩) ⇒/ (1⟨_,/_⟩))" [51,0,0,0,0] 81)
and evals⇩1 :: "J⇩1_prog ⇒ expr⇩1 list ⇒ state⇩1 ⇒ expr⇩1 list ⇒ state⇩1 ⇒ bool"
("_ ⊢⇩1 ((1⟨_,/_⟩) [⇒]/ (1⟨_,/_⟩))" [51,0,0,0,0] 81)
for P :: J⇩1_prog
where
New⇩1:
"⟦ new_Addr h = Some a; P ⊢ C has_fields FDTs; h' = h(a↦(C,init_fields FDTs)) ⟧
⟹ P ⊢⇩1 ⟨new C,(h,l)⟩ ⇒ ⟨addr a,(h',l)⟩"
| NewFail⇩1:
"new_Addr h = None ⟹
P ⊢⇩1 ⟨new C, (h,l)⟩ ⇒ ⟨THROW OutOfMemory,(h,l)⟩"
| Cast⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨addr a,(h,l)⟩; h a = Some(D,fs); P ⊢ D ≼⇧* C ⟧
⟹ P ⊢⇩1 ⟨Cast C e,s⇩0⟩ ⇒ ⟨addr a,(h,l)⟩"
| CastNull⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩ ⟹
P ⊢⇩1 ⟨Cast C e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩"
| CastFail⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨addr a,(h,l)⟩; h a = Some(D,fs); ¬ P ⊢ D ≼⇧* C ⟧
⟹ P ⊢⇩1 ⟨Cast C e,s⇩0⟩ ⇒ ⟨THROW ClassCast,(h,l)⟩"
| CastThrow⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢⇩1 ⟨Cast C e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| Val⇩1:
"P ⊢⇩1 ⟨Val v,s⟩ ⇒ ⟨Val v,s⟩"
| BinOp⇩1:
"⟦ P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨Val v⇩1,s⇩1⟩; P ⊢⇩1 ⟨e⇩2,s⇩1⟩ ⇒ ⟨Val v⇩2,s⇩2⟩; binop(bop,v⇩1,v⇩2) = Some v ⟧
⟹ P ⊢⇩1 ⟨e⇩1 «bop» e⇩2,s⇩0⟩ ⇒ ⟨Val v,s⇩2⟩"
| BinOpThrow⇩1⇩1:
"P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨throw e,s⇩1⟩ ⟹
P ⊢⇩1 ⟨e⇩1 «bop» e⇩2, s⇩0⟩ ⇒ ⟨throw e,s⇩1⟩"
| BinOpThrow⇩2⇩1:
"⟦ P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨Val v⇩1,s⇩1⟩; P ⊢⇩1 ⟨e⇩2,s⇩1⟩ ⇒ ⟨throw e,s⇩2⟩ ⟧
⟹ P ⊢⇩1 ⟨e⇩1 «bop» e⇩2,s⇩0⟩ ⇒ ⟨throw e,s⇩2⟩"
| Var⇩1:
"⟦ ls!i = v; i < size ls ⟧ ⟹
P ⊢⇩1 ⟨Var i,(h,ls)⟩ ⇒ ⟨Val v,(h,ls)⟩"
| LAss⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨Val v,(h,ls)⟩; i < size ls; ls' = ls[i := v] ⟧
⟹ P ⊢⇩1 ⟨i:= e,s⇩0⟩ ⇒ ⟨unit,(h,ls')⟩"
| LAssThrow⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢⇩1 ⟨i:= e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| FAcc⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨addr a,(h,ls)⟩; h a = Some(C,fs); fs(F,D) = Some v ⟧
⟹ P ⊢⇩1 ⟨e∙F{D},s⇩0⟩ ⇒ ⟨Val v,(h,ls)⟩"
| FAccNull⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩ ⟹
P ⊢⇩1 ⟨e∙F{D},s⇩0⟩ ⇒ ⟨THROW NullPointer,s⇩1⟩"
| FAccThrow⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢⇩1 ⟨e∙F{D},s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| FAss⇩1:
"⟦ P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨addr a,s⇩1⟩; P ⊢⇩1 ⟨e⇩2,s⇩1⟩ ⇒ ⟨Val v,(h⇩2,l⇩2)⟩;
h⇩2 a = Some(C,fs); fs' = fs((F,D)↦v); h⇩2' = h⇩2(a↦(C,fs')) ⟧
⟹ P ⊢⇩1 ⟨e⇩1∙F{D}:= e⇩2,s⇩0⟩ ⇒ ⟨unit,(h⇩2',l⇩2)⟩"
| FAssNull⇩1:
"⟦ P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨null,s⇩1⟩; P ⊢⇩1 ⟨e⇩2,s⇩1⟩ ⇒ ⟨Val v,s⇩2⟩ ⟧
⟹ P ⊢⇩1 ⟨e⇩1∙F{D}:= e⇩2,s⇩0⟩ ⇒ ⟨THROW NullPointer,s⇩2⟩"
| FAssThrow⇩1⇩1:
"P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢⇩1 ⟨e⇩1∙F{D}:= e⇩2,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| FAssThrow⇩2⇩1:
"⟦ P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨Val v,s⇩1⟩; P ⊢⇩1 ⟨e⇩2,s⇩1⟩ ⇒ ⟨throw e',s⇩2⟩ ⟧
⟹ P ⊢⇩1 ⟨e⇩1∙F{D}:= e⇩2,s⇩0⟩ ⇒ ⟨throw e',s⇩2⟩"
| CallObjThrow⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢⇩1 ⟨e∙M(es),s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| CallNull⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩; P ⊢⇩1 ⟨es,s⇩1⟩ [⇒] ⟨map Val vs,s⇩2⟩ ⟧
⟹ P ⊢⇩1 ⟨e∙M(es),s⇩0⟩ ⇒ ⟨THROW NullPointer,s⇩2⟩"
| Call⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨addr a,s⇩1⟩; P ⊢⇩1 ⟨es,s⇩1⟩ [⇒] ⟨map Val vs,(h⇩2,ls⇩2)⟩;
h⇩2 a = Some(C,fs); P ⊢ C sees M:Ts→T = body in D;
size vs = size Ts; ls⇩2' = (Addr a) # vs @ replicate (max_vars body) undefined;
P ⊢⇩1 ⟨body,(h⇩2,ls⇩2')⟩ ⇒ ⟨e',(h⇩3,ls⇩3)⟩ ⟧
⟹ P ⊢⇩1 ⟨e∙M(es),s⇩0⟩ ⇒ ⟨e',(h⇩3,ls⇩2)⟩"
| CallParamsThrow⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨Val v,s⇩1⟩; P ⊢⇩1 ⟨es,s⇩1⟩ [⇒] ⟨es',s⇩2⟩;
es' = map Val vs @ throw ex # es⇩2 ⟧
⟹ P ⊢⇩1 ⟨e∙M(es),s⇩0⟩ ⇒ ⟨throw ex,s⇩2⟩"
| Block⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨e',s⇩1⟩ ⟹ P ⊢⇩1 ⟨Block i T e,s⇩0⟩ ⇒ ⟨e',s⇩1⟩"
| Seq⇩1:
"⟦ P ⊢⇩1 ⟨e⇩0,s⇩0⟩ ⇒ ⟨Val v,s⇩1⟩; P ⊢⇩1 ⟨e⇩1,s⇩1⟩ ⇒ ⟨e⇩2,s⇩2⟩ ⟧
⟹ P ⊢⇩1 ⟨e⇩0;;e⇩1,s⇩0⟩ ⇒ ⟨e⇩2,s⇩2⟩"
| SeqThrow⇩1:
"P ⊢⇩1 ⟨e⇩0,s⇩0⟩ ⇒ ⟨throw e,s⇩1⟩ ⟹
P ⊢⇩1 ⟨e⇩0;;e⇩1,s⇩0⟩ ⇒ ⟨throw e,s⇩1⟩"
| CondT⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨true,s⇩1⟩; P ⊢⇩1 ⟨e⇩1,s⇩1⟩ ⇒ ⟨e',s⇩2⟩ ⟧
⟹ P ⊢⇩1 ⟨if (e) e⇩1 else e⇩2,s⇩0⟩ ⇒ ⟨e',s⇩2⟩"
| CondF⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨false,s⇩1⟩; P ⊢⇩1 ⟨e⇩2,s⇩1⟩ ⇒ ⟨e',s⇩2⟩ ⟧
⟹ P ⊢⇩1 ⟨if (e) e⇩1 else e⇩2,s⇩0⟩ ⇒ ⟨e',s⇩2⟩"
| CondThrow⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢⇩1 ⟨if (e) e⇩1 else e⇩2, s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| WhileF⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨false,s⇩1⟩ ⟹
P ⊢⇩1 ⟨while (e) c,s⇩0⟩ ⇒ ⟨unit,s⇩1⟩"
| WhileT⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨true,s⇩1⟩; P ⊢⇩1 ⟨c,s⇩1⟩ ⇒ ⟨Val v⇩1,s⇩2⟩;
P ⊢⇩1 ⟨while (e) c,s⇩2⟩ ⇒ ⟨e⇩3,s⇩3⟩ ⟧
⟹ P ⊢⇩1 ⟨while (e) c,s⇩0⟩ ⇒ ⟨e⇩3,s⇩3⟩"
| WhileCondThrow⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢⇩1 ⟨while (e) c,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| WhileBodyThrow⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨true,s⇩1⟩; P ⊢⇩1 ⟨c,s⇩1⟩ ⇒ ⟨throw e',s⇩2⟩⟧
⟹ P ⊢⇩1 ⟨while (e) c,s⇩0⟩ ⇒ ⟨throw e',s⇩2⟩"
| Throw⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨addr a,s⇩1⟩ ⟹
P ⊢⇩1 ⟨throw e,s⇩0⟩ ⇒ ⟨Throw a,s⇩1⟩"
| ThrowNull⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨null,s⇩1⟩ ⟹
P ⊢⇩1 ⟨throw e,s⇩0⟩ ⇒ ⟨THROW NullPointer,s⇩1⟩"
| ThrowThrow⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢⇩1 ⟨throw e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩"
| Try⇩1:
"P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨Val v⇩1,s⇩1⟩ ⟹
P ⊢⇩1 ⟨try e⇩1 catch(C i) e⇩2,s⇩0⟩ ⇒ ⟨Val v⇩1,s⇩1⟩"
| TryCatch⇩1:
"⟦ P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨Throw a,(h⇩1,ls⇩1)⟩;
h⇩1 a = Some(D,fs); P ⊢ D ≼⇧* C; i < length ls⇩1;
P ⊢⇩1 ⟨e⇩2,(h⇩1,ls⇩1[i:=Addr a])⟩ ⇒ ⟨e⇩2',(h⇩2,ls⇩2)⟩ ⟧
⟹ P ⊢⇩1 ⟨try e⇩1 catch(C i) e⇩2,s⇩0⟩ ⇒ ⟨e⇩2',(h⇩2,ls⇩2)⟩"
| TryThrow⇩1:
"⟦ P ⊢⇩1 ⟨e⇩1,s⇩0⟩ ⇒ ⟨Throw a,(h⇩1,ls⇩1)⟩; h⇩1 a = Some(D,fs); ¬ P ⊢ D ≼⇧* C ⟧
⟹ P ⊢⇩1 ⟨try e⇩1 catch(C i) e⇩2,s⇩0⟩ ⇒ ⟨Throw a,(h⇩1,ls⇩1)⟩"
| Nil⇩1:
"P ⊢⇩1 ⟨[],s⟩ [⇒] ⟨[],s⟩"
| Cons⇩1:
"⟦ P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨Val v,s⇩1⟩; P ⊢⇩1 ⟨es,s⇩1⟩ [⇒] ⟨es',s⇩2⟩ ⟧
⟹ P ⊢⇩1 ⟨e#es,s⇩0⟩ [⇒] ⟨Val v # es',s⇩2⟩"
| ConsThrow⇩1:
"P ⊢⇩1 ⟨e,s⇩0⟩ ⇒ ⟨throw e',s⇩1⟩ ⟹
P ⊢⇩1 ⟨e#es,s⇩0⟩ [⇒] ⟨throw e' # es, s⇩1⟩"
lemmas eval⇩1_evals⇩1_induct = eval⇩1_evals⇩1.induct [split_format (complete)]
and eval⇩1_evals⇩1_inducts = eval⇩1_evals⇩1.inducts [split_format (complete)]
lemma eval⇩1_preserves_len:
"P ⊢⇩1 ⟨e⇩0,(h⇩0,ls⇩0)⟩ ⇒ ⟨e⇩1,(h⇩1,ls⇩1)⟩ ⟹ length ls⇩0 = length ls⇩1"
and evals⇩1_preserves_len:
"P ⊢⇩1 ⟨es⇩0,(h⇩0,ls⇩0)⟩ [⇒] ⟨es⇩1,(h⇩1,ls⇩1)⟩ ⟹ length ls⇩0 = length ls⇩1"
by (induct rule:eval⇩1_evals⇩1_inducts, simp_all)
lemma evals⇩1_preserves_elen:
"⋀es' s s'. P ⊢⇩1 ⟨es,s⟩ [⇒] ⟨es',s'⟩ ⟹ length es = length es'"
apply(induct es type:list)
apply (auto elim:evals⇩1.cases)
done
lemma eval⇩1_final: "P ⊢⇩1 ⟨e,s⟩ ⇒ ⟨e',s'⟩ ⟹ final e'"
and evals⇩1_final: "P ⊢⇩1 ⟨es,s⟩ [⇒] ⟨es',s'⟩ ⟹ finals es'"
by(induct rule:eval⇩1_evals⇩1.inducts, simp_all)
end
Theory J1WellForm
section ‹Well-Formedness of Intermediate Language›
theory J1WellForm
imports "../J/JWellForm" J1
begin
subsection "Well-Typedness"
type_synonym
env⇩1 = "ty list"
inductive
WT⇩1 :: "[J⇩1_prog,env⇩1, expr⇩1 , ty ] ⇒ bool"
("(_,_ ⊢⇩1/ _ :: _)" [51,51,51]50)
and WTs⇩1 :: "[J⇩1_prog,env⇩1, expr⇩1 list, ty list] ⇒ bool"
("(_,_ ⊢⇩1/ _ [::] _)" [51,51,51]50)
for P :: J⇩1_prog
where
WTNew⇩1:
"is_class P C ⟹
P,E ⊢⇩1 new C :: Class C"
| WTCast⇩1:
"⟦ P,E ⊢⇩1 e :: Class D; is_class P C; P ⊢ C ≼⇧* D ∨ P ⊢ D ≼⇧* C ⟧
⟹ P,E ⊢⇩1 Cast C e :: Class C"
| WTVal⇩1:
"typeof v = Some T ⟹
P,E ⊢⇩1 Val v :: T"
| WTVar⇩1:
"⟦ E!i = T; i < size E ⟧
⟹ P,E ⊢⇩1 Var i :: T"
| WTBinOp⇩1:
"⟦ P,E ⊢⇩1 e⇩1 :: T⇩1; P,E ⊢⇩1 e⇩2 :: T⇩2;
case bop of Eq ⇒ (P ⊢ T⇩1 ≤ T⇩2 ∨ P ⊢ T⇩2 ≤ T⇩1) ∧ T = Boolean
| Add ⇒ T⇩1 = Integer ∧ T⇩2 = Integer ∧ T = Integer ⟧
⟹ P,E ⊢⇩1 e⇩1 «bop» e⇩2 :: T"
| WTLAss⇩1:
"⟦ E!i = T; i < size E; P,E ⊢⇩1 e :: T'; P ⊢ T' ≤ T ⟧
⟹ P,E ⊢⇩1 i:=e :: Void"
| WTFAcc⇩1:
"⟦ P,E ⊢⇩1 e :: Class C; P ⊢ C sees F:T in D ⟧
⟹ P,E ⊢⇩1 e∙F{D} :: T"
| WTFAss⇩1:
"⟦ P,E ⊢⇩1 e⇩1 :: Class C; P ⊢ C sees F:T in D; P,E ⊢⇩1 e⇩2 :: T'; P ⊢ T' ≤ T ⟧
⟹ P,E ⊢⇩1 e⇩1∙F{D} := e⇩2 :: Void"
| WTCall⇩1:
"⟦ P,E ⊢⇩1 e :: Class C; P ⊢ C sees M:Ts' → T = m in D;
P,E ⊢⇩1 es [::] Ts; P ⊢ Ts [≤] Ts' ⟧
⟹ P,E ⊢⇩1 e∙M(es) :: T"
| WTBlock⇩1:
"⟦ is_type P T; P,E@[T] ⊢⇩1 e::T' ⟧
⟹ P,E ⊢⇩1 {i:T; e} :: T'"
| WTSeq⇩1:
"⟦ P,E ⊢⇩1 e⇩1::T⇩1; P,E ⊢⇩1 e⇩2::T⇩2 ⟧
⟹ P,E ⊢⇩1 e⇩1;;e⇩2 :: T⇩2"
| WTCond⇩1:
"⟦ P,E ⊢⇩1 e :: Boolean; P,E ⊢⇩1 e⇩1::T⇩1; P,E ⊢⇩1 e⇩2::T⇩2;
P ⊢ T⇩1 ≤ T⇩2 ∨ P ⊢ T⇩2 ≤ T⇩1; P ⊢ T⇩1 ≤ T⇩2 ⟶ T = T⇩2; P ⊢ T⇩2 ≤ T⇩1 ⟶ T = T⇩1 ⟧
⟹ P,E ⊢⇩1 if (e) e⇩1 else e⇩2 :: T"
| WTWhile⇩1:
"⟦ P,E ⊢⇩1 e :: Boolean; P,E ⊢⇩1 c::T ⟧
⟹ P,E ⊢⇩1 while (e) c :: Void"
| WTThrow⇩1:
"P,E ⊢⇩1 e :: Class C ⟹
P,E ⊢⇩1 throw e :: Void"
| WTTry⇩1:
"⟦ P,E ⊢⇩1 e⇩1 :: T; P,E@[Class C] ⊢⇩1 e⇩2 :: T; is_class P C ⟧
⟹ P,E ⊢⇩1 try e⇩1 catch(C i) e⇩2 :: T"
| WTNil⇩1:
"P,E ⊢⇩1 [] [::] []"
| WTCons⇩1:
"⟦ P,E ⊢⇩1 e :: T; P,E ⊢⇩1 es [::] Ts ⟧
⟹ P,E ⊢⇩1 e#es [::] T#Ts"
declare WT⇩1_WTs⇩1.intros[intro!]
declare WTNil⇩1[iff]
lemmas WT⇩1_WTs⇩1_induct = WT⇩1_WTs⇩1.induct [split_format (complete)]
and WT⇩1_WTs⇩1_inducts = WT⇩1_WTs⇩1.inducts [split_format (complete)]
inductive_cases eee[elim!]:
"P,E ⊢⇩1 Val v :: T"
"P,E ⊢⇩1 Var i :: T"
"P,E ⊢⇩1 Cast D e :: T"
"P,E ⊢⇩1 i:=e :: T"
"P,E ⊢⇩1 {i:U; e} :: T"
"P,E ⊢⇩1 e⇩1;;e⇩2 :: T"
"P,E ⊢⇩1 if (e) e⇩1 else e⇩2 :: T"
"P,E ⊢⇩1 while (e) c :: T"
"P,E ⊢⇩1 throw e :: T"
"P,E ⊢⇩1 try e⇩1 catch(C i) e⇩2 :: T"
"P,E ⊢⇩1 e∙F{D} :: T"
"P,E ⊢⇩1 e⇩1∙F{D}:=e⇩2 :: T"
"P,E ⊢⇩1 e⇩1 «bop» e⇩2 :: T"
"P,E ⊢⇩1 new C :: T"
"P,E ⊢⇩1 e∙M(es) :: T"
"P,E ⊢⇩1 [] [::] Ts"
"P,E ⊢⇩1 e#es [::] Ts"
lemma WTs⇩1_same_size: "⋀Ts. P,E ⊢⇩1 es [::] Ts ⟹ size es = size Ts"
by (induct es type:list) auto
lemma WT⇩1_unique:
"P,E ⊢⇩1 e :: T⇩1 ⟹ (⋀T⇩2. P,E ⊢⇩1 e :: T⇩2 ⟹ T⇩1 = T⇩2)" and
"P,E ⊢⇩1 es [::] Ts⇩1 ⟹ (⋀Ts⇩2. P,E ⊢⇩1 es [::] Ts⇩2 ⟹ Ts⇩1 = Ts⇩2)"
apply(induct rule:WT⇩1_WTs⇩1.inducts)
apply blast
apply blast
apply clarsimp
apply blast
apply clarsimp
apply(case_tac bop)
apply clarsimp
apply clarsimp
apply blast
apply (blast dest:sees_field_idemp sees_field_fun)
apply blast
apply (blast dest:sees_method_idemp sees_method_fun)
apply blast
apply blast
apply blast
apply blast
apply clarify
apply blast
apply blast
apply blast
done
lemma assumes wf: "wf_prog p P"
shows WT⇩1_is_type: "P,E ⊢⇩1 e :: T ⟹ set E ⊆ types P ⟹ is_type P T"
and "P,E ⊢⇩1 es [::] Ts ⟹ True"
apply(induct rule:WT⇩1_WTs⇩1.inducts)
apply simp
apply simp
apply (simp add:typeof_lit_is_type)
apply (blast intro:nth_mem)
apply(simp split:bop.splits)
apply simp
apply (simp add:sees_field_is_type[OF _ wf])
apply simp
apply(fastforce dest!: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
apply simp
apply simp
apply blast
apply simp
apply simp
apply simp
apply simp
apply simp
done
subsection‹Well-formedness›
primrec ℬ :: "expr⇩1 ⇒ nat ⇒ bool"
and ℬs :: "expr⇩1 list ⇒ nat ⇒ bool" where
"ℬ (new C) i = True" |
"ℬ (Cast C e) i = ℬ e i" |
"ℬ (Val v) i = True" |
"ℬ (e⇩1 «bop» e⇩2) i = (ℬ e⇩1 i ∧ ℬ e⇩2 i)" |
"ℬ (Var j) i = True" |
"ℬ (e∙F{D}) i = ℬ e i" |
"ℬ (j:=e) i = ℬ e i" |
"ℬ (e⇩1∙F{D} := e⇩2) i = (ℬ e⇩1 i ∧ ℬ e⇩2 i)" |
"ℬ (e∙M(es)) i = (ℬ e i ∧ ℬs es i)" |
"ℬ ({j:T ; e}) i = (i = j ∧ ℬ e (i+1))" |
"ℬ (e⇩1;;e⇩2) i = (ℬ e⇩1 i ∧ ℬ e⇩2 i)" |
"ℬ (if (e) e⇩1 else e⇩2) i = (ℬ e i ∧ ℬ e⇩1 i ∧ ℬ e⇩2 i)" |
"ℬ (throw e) i = ℬ e i" |
"ℬ (while (e) c) i = (ℬ e i ∧ ℬ c i)" |
"ℬ (try e⇩1 catch(C j) e⇩2) i = (ℬ e⇩1 i ∧ i=j ∧ ℬ e⇩2 (i+1))" |
"ℬs [] i = True" |
"ℬs (e#es) i = (ℬ e i ∧ ℬs es i)"
definition wf_J⇩1_mdecl :: "J⇩1_prog ⇒ cname ⇒ expr⇩1 mdecl ⇒ bool"
where
"wf_J⇩1_mdecl P C ≡ λ(M,Ts,T,body).
(∃T'. P,Class C#Ts ⊢⇩1 body :: T' ∧ P ⊢ T' ≤ T) ∧
𝒟 body ⌊{..size Ts}⌋ ∧ ℬ body (size Ts + 1)"
lemma wf_J⇩1_mdecl[simp]:
"wf_J⇩1_mdecl P C (M,Ts,T,body) ≡
((∃T'. P,Class C#Ts ⊢⇩1 body :: T' ∧ P ⊢ T' ≤ T) ∧
𝒟 body ⌊{..size Ts}⌋ ∧ ℬ body (size Ts + 1))"
by (simp add:wf_J⇩1_mdecl_def)
abbreviation "wf_J⇩1_prog == wf_prog wf_J⇩1_mdecl"
end
Theory PCompiler
section ‹Program Compilation›
theory PCompiler
imports "../Common/WellForm"
begin
definition compM :: "('a ⇒ 'b) ⇒ 'a mdecl ⇒ 'b mdecl"
where
"compM f ≡ λ(M, Ts, T, m). (M, Ts, T, f m)"
definition compC :: "('a ⇒ 'b) ⇒ 'a cdecl ⇒ 'b cdecl"
where
"compC f ≡ λ(C,D,Fdecls,Mdecls). (C,D,Fdecls, map (compM f) Mdecls)"
definition compP :: "('a ⇒ 'b) ⇒ 'a prog ⇒ 'b prog"
where
"compP f ≡ map (compC f)"
text‹Compilation preserves the program structure. Therfore lookup
functions either commute with compilation (like method lookup) or are
preserved by it (like the subclass relation).›
lemma map_of_map4:
"map_of (map (λ(x,a,b,c).(x,a,b,f c)) ts) =
map_option (λ(a,b,c).(a,b,f c)) ∘ (map_of ts)"
apply(induct ts)
apply simp
apply(rule ext)
apply fastforce
done
lemma class_compP:
"class P C = Some (D, fs, ms)
⟹ class (compP f P) C = Some (D, fs, map (compM f) ms)"
by(simp add:class_def compP_def compC_def map_of_map4)
lemma class_compPD:
"class (compP f P) C = Some (D, fs, cms)
⟹ ∃ms. class P C = Some(D,fs,ms) ∧ cms = map (compM f) ms"
by(clarsimp simp add:class_def compP_def compC_def map_of_map4)
lemma [simp]: "is_class (compP f P) C = is_class P C"
by(auto simp:is_class_def dest: class_compP class_compPD)
lemma [simp]: "class (compP f P) C = map_option (λc. snd(compC f (C,c))) (class P C)"
apply(simp add:compP_def compC_def class_def map_of_map4)
apply(simp add:split_def)
done
lemma sees_methods_compP:
"P ⊢ C sees_methods Mm ⟹
compP f P ⊢ C sees_methods (map_option (λ((Ts,T,m),D). ((Ts,T,f m),D)) ∘ Mm)"
apply(erule Methods.induct)
apply(rule sees_methods_Object)
apply(erule class_compP)
apply(rule ext)
apply(simp add:compM_def map_of_map4 option.map_comp)
apply(case_tac "map_of ms x")
apply simp
apply fastforce
apply(rule sees_methods_rec)
apply(erule class_compP)
apply assumption
apply assumption
apply(rule ext)
apply(simp add:map_add_def compM_def map_of_map4 option.map_comp split:option.split)
done
lemma sees_method_compP:
"P ⊢ C sees M: Ts→T = m in D ⟹
compP f P ⊢ C sees M: Ts→T = (f m) in D"
by(fastforce elim:sees_methods_compP simp add:Method_def)
lemma [simp]:
"P ⊢ C sees M: Ts→T = m in D ⟹
method (compP f P) C M = (D,Ts,T,f m)"
apply(drule sees_method_compP)
apply(simp add:method_def)
apply(rule the_equality)
apply simp
apply(fastforce dest:sees_method_fun)
done
lemma sees_methods_compPD:
"⟦ cP ⊢ C sees_methods Mm'; cP = compP f P ⟧ ⟹
∃Mm. P ⊢ C sees_methods Mm ∧
Mm' = (map_option (λ((Ts,T,m),D). ((Ts,T,f m),D)) ∘ Mm)"
apply(erule Methods.induct)
apply(clarsimp simp:compC_def)
apply(rule exI)
apply(rule conjI, erule sees_methods_Object)
apply(rule refl)
apply(rule ext)
apply(simp add:compM_def map_of_map4 option.map_comp)
apply(case_tac "map_of b x")
apply simp
apply fastforce
apply(clarsimp simp:compC_def)
apply(rule exI, rule conjI)
apply(erule (2) sees_methods_rec)
apply(rule refl)
apply(rule ext)
apply(simp add:map_add_def compM_def map_of_map4 option.map_comp split:option.split)
done
lemma sees_method_compPD:
"compP f P ⊢ C sees M: Ts→T = fm in D ⟹
∃m. P ⊢ C sees M: Ts→T = m in D ∧ f m = fm"
apply(simp add:Method_def)
apply clarify
apply(drule sees_methods_compPD[OF _ refl])
apply clarsimp
apply blast
done
lemma [simp]: "subcls1(compP f P) = subcls1 P"
by(fastforce simp add: is_class_def compC_def intro:subcls1I order_antisym dest:subcls1D)
lemma compP_widen[simp]: "(compP f P ⊢ T ≤ T') = (P ⊢ T ≤ T')"
by(cases T')(simp_all add:widen_Class)
lemma [simp]: "(compP f P ⊢ Ts [≤] Ts') = (P ⊢ Ts [≤] Ts')"
apply(induct Ts)
apply simp
apply(cases Ts')
apply(auto simp:fun_of_def)
done
lemma [simp]: "is_type (compP f P) T = is_type P T"
by(cases T) simp_all
lemma [simp]: "(compP (f::'a⇒'b) P ⊢ C has_fields FDTs) = (P ⊢ C has_fields FDTs)"
(is "?A = ?B")
proof
{ fix cP::"'b prog" assume "cP ⊢ C has_fields FDTs"
hence "cP = compP f P ⟹ P ⊢ C has_fields FDTs"
proof induct
case has_fields_Object
thus ?case by(fast intro:Fields.has_fields_Object dest:class_compPD)
next
case has_fields_rec
thus ?case by(fast intro:Fields.has_fields_rec dest:class_compPD)
qed
} note lem = this
assume ?A
with lem show ?B by blast
next
assume ?B
thus ?A
proof induct
case has_fields_Object
thus ?case by(fast intro:Fields.has_fields_Object class_compP)
next
case has_fields_rec
thus ?case by(fast intro:Fields.has_fields_rec class_compP)
qed
qed
lemma [simp]: "fields (compP f P) C = fields P C"
by(simp add:fields_def)
lemma [simp]: "(compP f P ⊢ C sees F:T in D) = (P ⊢ C sees F:T in D)"
by(simp add:sees_field_def)
lemma [simp]: "field (compP f P) F D = field P F D"
by(simp add:field_def)
subsection‹Invariance of @{term wf_prog} under compilation›
lemma [iff]: "distinct_fst (compP f P) = distinct_fst P"
apply(simp add:distinct_fst_def compP_def compC_def)
apply(induct P)
apply (auto simp:image_iff)
done
lemma [iff]: "distinct_fst (map (compM f) ms) = distinct_fst ms"
apply(simp add:distinct_fst_def compM_def)
apply(induct ms)
apply (auto simp:image_iff)
done
lemma [iff]: "wf_syscls (compP f P) = wf_syscls P"
by(simp add:wf_syscls_def compP_def compC_def image_def Bex_def)
lemma [iff]: "wf_fdecl (compP f P) = wf_fdecl P"
by(simp add:wf_fdecl_def)
lemma set_compP:
"((C,D,fs,ms') ∈ set(compP f P)) =
(∃ms. (C,D,fs,ms) ∈ set P ∧ ms' = map (compM f) ms)"
by(fastforce simp add:compP_def compC_def image_iff Bex_def)
lemma wf_cdecl_compPI:
"⟦ ⋀C M Ts T m.
⟦ wf_mdecl wf⇩1 P C (M,Ts,T,m); P ⊢ C sees M:Ts→T = m in C ⟧
⟹ wf_mdecl wf⇩2 (compP f P) C (M,Ts,T, f m);
∀x∈set P. wf_cdecl wf⇩1 P x; x ∈ set (compP f P); wf_prog p P ⟧
⟹ wf_cdecl wf⇩2 (compP f P) x"
apply(clarsimp simp add:wf_cdecl_def Ball_def set_compP)
apply(rename_tac C D fs ms)
apply(rule conjI)
apply (clarsimp simp:compM_def)
apply (drule (2) mdecl_visible)
apply simp
apply(clarify)
apply(drule sees_method_compPD[where f = f])
apply clarsimp
apply(fastforce simp:image_iff compM_def)
done
lemma wf_prog_compPI:
assumes lift:
"⋀C M Ts T m.
⟦ P ⊢ C sees M:Ts→T = m in C; wf_mdecl wf⇩1 P C (M,Ts,T,m) ⟧
⟹ wf_mdecl wf⇩2 (compP f P) C (M,Ts,T, f m)"
and wf: "wf_prog wf⇩1 P"
shows "wf_prog wf⇩2 (compP f P)"
using wf
by (simp add:wf_prog_def) (blast intro:wf_cdecl_compPI lift wf)
end
Theory Hidden
theory Hidden
imports "List-Index.List_Index"
begin
definition hidden :: "'a list ⇒ nat ⇒ bool" where
"hidden xs i ≡ i < size xs ∧ xs!i ∈ set(drop (i+1) xs)"
lemma hidden_last_index: "x ∈ set xs ⟹ hidden (xs @ [x]) (last_index xs x)"
apply(auto simp add: hidden_def nth_append rev_nth[symmetric])
apply(drule last_index_less[OF _ le_refl])
apply simp
done
lemma hidden_inacc: "hidden xs i ⟹ last_index xs x ≠ i"
by(auto simp add: hidden_def last_index_drop last_index_less_size_conv)
lemma [simp]: "hidden xs i ⟹ hidden (xs@[x]) i"
by(auto simp add:hidden_def nth_append)
lemma fun_upds_apply:
"(m(xs[↦]ys)) x =
(let xs' = take (size ys) xs
in if x ∈ set xs' then Some(ys ! last_index xs' x) else m x)"
apply(induct xs arbitrary: m ys)
apply (simp add: Let_def)
apply(case_tac ys)
apply (simp add:Let_def)
apply (simp add: Let_def last_index_Cons)
done
lemma map_upds_apply_eq_Some:
"((m(xs[↦]ys)) x = Some y) =
(let xs' = take (size ys) xs
in if x ∈ set xs' then ys ! last_index xs' x = y else m x = Some y)"
by(simp add:fun_upds_apply Let_def)
lemma map_upds_upd_conv_last_index:
"⟦x ∈ set xs; size xs ≤ size ys ⟧
⟹ m(xs[↦]ys)(x↦y) = m(xs[↦]ys[last_index xs x := y])"
apply(rule ext)
apply(simp add:fun_upds_apply eq_sym_conv Let_def)
done
end
Theory Compiler1
section ‹Compilation Stage 1›
theory Compiler1 imports PCompiler J1 Hidden begin
text‹Replacing variable names by indices.›
primrec compE⇩1 :: "vname list ⇒ expr ⇒ expr⇩1"
and compEs⇩1 :: "vname list ⇒ expr list ⇒ expr⇩1 list" where
"compE⇩1 Vs (new C) = new C"
| "compE⇩1 Vs (Cast C e) = Cast C (compE⇩1 Vs e)"
| "compE⇩1 Vs (Val v) = Val v"
| "compE⇩1 Vs (e⇩1 «bop» e⇩2) = (compE⇩1 Vs e⇩1) «bop» (compE⇩1 Vs e⇩2)"
| "compE⇩1 Vs (Var V) = Var(last_index Vs V)"
| "compE⇩1 Vs (V:=e) = (last_index Vs V):= (compE⇩1 Vs e)"
| "compE⇩1 Vs (e∙F{D}) = (compE⇩1 Vs e)∙F{D}"
| "compE⇩1 Vs (e⇩1∙F{D}:=e⇩2) = (compE⇩1 Vs e⇩1)∙F{D} := (compE⇩1 Vs e⇩2)"
| "compE⇩1 Vs (e∙M(es)) = (compE⇩1 Vs e)∙M(compEs⇩1 Vs es)"
| "compE⇩1 Vs {V:T; e} = {(size Vs):T; compE⇩1 (Vs@[V]) e}"
| "compE⇩1 Vs (e⇩1;;e⇩2) = (compE⇩1 Vs e⇩1);;(compE⇩1 Vs e⇩2)"
| "compE⇩1 Vs (if (e) e⇩1 else e⇩2) = if (compE⇩1 Vs e) (compE⇩1 Vs e⇩1) else (compE⇩1 Vs e⇩2)"
| "compE⇩1 Vs (while (e) c) = while (compE⇩1 Vs e) (compE⇩1 Vs c)"
| "compE⇩1 Vs (throw e) = throw (compE⇩1 Vs e)"
| "compE⇩1 Vs (try e⇩1 catch(C V) e⇩2) =
try(compE⇩1 Vs e⇩1) catch(C (size Vs)) (compE⇩1 (Vs@[V]) e⇩2)"
| "compEs⇩1 Vs [] = []"
| "compEs⇩1 Vs (e#es) = compE⇩1 Vs e # compEs⇩1 Vs es"
lemma [simp]: "compEs⇩1 Vs es = map (compE⇩1 Vs) es"
by(induct es type:list) simp_all
primrec fin⇩1:: "expr ⇒ expr⇩1" where
"fin⇩1(Val v) = Val v"
| "fin⇩1(throw e) = throw(fin⇩1 e)"
lemma comp_final: "final e ⟹ compE⇩1 Vs e = fin⇩1 e"
by(erule finalE, simp_all)
lemma [simp]:
"⋀Vs. max_vars (compE⇩1 Vs e) = max_vars e"
and "⋀Vs. max_varss (compEs⇩1 Vs es) = max_varss es"
by (induct e and es rule: max_vars.induct max_varss.induct) simp_all
text‹Compiling programs:›
definition compP⇩1 :: "J_prog ⇒ J⇩1_prog"
where
"compP⇩1 ≡ compP (λ(pns,body). compE⇩1 (this#pns) body)"
declare compP⇩1_def[simp]
end
Theory Correctness1
section ‹Correctness of Stage 1›
theory Correctness1
imports J1WellForm Compiler1
begin
subsection‹Correctness of program compilation›
primrec unmod :: "expr⇩1 ⇒ nat ⇒ bool"
and unmods :: "expr⇩1 list ⇒ nat ⇒ bool" where
"unmod (new C) i = True" |
"unmod (Cast C e) i = unmod e i" |
"unmod (Val v) i = True" |
"unmod (e⇩1 «bop» e⇩2) i = (unmod e⇩1 i ∧ unmod e⇩2 i)" |
"unmod (Var i) j = True" |
"unmod (i:=e) j = (i ≠ j ∧ unmod e j)" |
"unmod (e∙F{D}) i = unmod e i" |
"unmod (e⇩1∙F{D}:=e⇩2) i = (unmod e⇩1 i ∧ unmod e⇩2 i)" |
"unmod (e∙M(es)) i = (unmod e i ∧ unmods es i)" |
"unmod {j:T; e} i = unmod e i" |
"unmod (e⇩1;;e⇩2) i = (unmod e⇩1 i ∧ unmod e⇩2 i)" |
"unmod (if (e) e⇩1 else e⇩2) i = (unmod e i ∧ unmod e⇩1 i ∧ unmod e⇩2 i)" |
"unmod (while (e) c) i = (unmod e i ∧ unmod c i)" |
"unmod (throw e) i = unmod e i" |
"unmod (try e⇩1 catch(C i) e⇩2) j = (unmod e⇩1 j ∧ (if i=j then False else unmod e⇩2 j))" |
"unmods ([]) i = True" |
"unmods (e#es) i = (unmod e i ∧ unmods es i)"
lemma hidden_unmod: "⋀Vs. hidden Vs i ⟹ unmod (compE⇩1 Vs e) i" and
"⋀Vs. hidden Vs i ⟹ unmods (compEs⇩1 Vs es) i"
apply(induct e and es rule: compE⇩1.induct compEs⇩1.induct)
apply (simp_all add:hidden_inacc)
apply(auto simp add:hidden_def)
done
lemma eval⇩1_preserves_unmod:
"⟦ P ⊢⇩1 ⟨e,(h,ls)⟩ ⇒ ⟨e',(h',ls')⟩; unmod e i; i < size ls ⟧
⟹ ls ! i = ls' ! i"
and "⟦ P ⊢⇩1 ⟨es,(h,ls)⟩ [⇒] ⟨es',(h',ls')⟩; unmods es i; i < size ls ⟧
⟹ ls ! i = ls' ! i"
apply(induct rule:eval⇩1_evals⇩1_inducts)
apply(auto dest!:eval⇩1_preserves_len split:if_split_asm)
done
lemma LAss_lem:
"⟦x ∈ set xs; size xs ≤ size ys ⟧
⟹ m⇩1 ⊆⇩m m⇩2(xs[↦]ys) ⟹ m⇩1(x↦y) ⊆⇩m m⇩2(xs[↦]ys[last_index xs x := y])"
by(simp add:map_le_def fun_upds_apply eq_sym_conv)
lemma Block_lem:
fixes l :: "'a ⇀ 'b"
assumes 0: "l ⊆⇩m [Vs [↦] ls]"
and 1: "l' ⊆⇩m [Vs [↦] ls', V↦v]"
and hidden: "V ∈ set Vs ⟹ ls ! last_index Vs V = ls' ! last_index Vs V"
and size: "size ls = size ls'" "size Vs < size ls'"
shows "l'(V := l V) ⊆⇩m [Vs [↦] ls']"
proof -
have "l'(V := l V) ⊆⇩m [Vs [↦] ls', V↦v](V := l V)"
using 1 by(rule map_le_upd)
also have "… = [Vs [↦] ls'](V := l V)" by simp
also have "… ⊆⇩m [Vs [↦] ls']"
proof (cases "l V")
case None thus ?thesis by simp
next
case (Some w)
hence "[Vs [↦] ls] V = Some w"
using 0 by(force simp add: map_le_def split:if_splits)
hence VinVs: "V ∈ set Vs" and w: "w = ls ! last_index Vs V"
using size by(auto simp add:fun_upds_apply split:if_splits)
hence "w = ls' ! last_index Vs V" using hidden[OF VinVs] by simp
hence "[Vs [↦] ls'](V := l V) = [Vs [↦] ls']" using Some size VinVs
by(simp add: map_upds_upd_conv_last_index)
thus ?thesis by simp
qed
finally show ?thesis .
qed
declare fun_upd_apply[simp del]
text‹\noindent The main theorem:›
theorem assumes wf: "wwf_J_prog P"
shows eval⇩1_eval: "P ⊢ ⟨e,(h,l)⟩ ⇒ ⟨e',(h',l')⟩
⟹ (⋀Vs ls. ⟦ fv e ⊆ set Vs; l ⊆⇩m [Vs[↦]ls]; size Vs + max_vars e ≤ size ls ⟧
⟹ ∃ls'. compP⇩1 P ⊢⇩1 ⟨compE⇩1 Vs e,(h,ls)⟩ ⇒ ⟨fin⇩1 e',(h',ls')⟩ ∧ l' ⊆⇩m [Vs[↦]ls'])"
(is "_ ⟹ (⋀Vs ls. PROP ?P e h l e' h' l' Vs ls)"
is "_ ⟹ (⋀Vs ls. ⟦ _; _; _ ⟧ ⟹ ∃ls'. ?Post e h l e' h' l' Vs ls ls')")
and evals⇩1_evals: "P ⊢ ⟨es,(h,l)⟩ [⇒] ⟨es',(h',l')⟩
⟹ (⋀Vs ls. ⟦ fvs es ⊆ set Vs; l ⊆⇩m [Vs[↦]ls]; size Vs + max_varss es ≤ size ls ⟧
⟹ ∃ls'. compP⇩1 P ⊢⇩1 ⟨compEs⇩1 Vs es,(h,ls)⟩ [⇒] ⟨compEs⇩1 Vs es',(h',ls')⟩ ∧
l' ⊆⇩m [Vs[↦]ls'])"
(is "_ ⟹ (⋀Vs ls. PROP ?Ps es h l es' h' l' Vs ls)"
is "_ ⟹ (⋀Vs ls. ⟦ _; _; _⟧ ⟹ ∃ls'. ?Posts es h l es' h' l' Vs ls ls')")
proof (induct rule:eval_evals_inducts)
case Nil thus ?case by(fastforce intro!:Nil⇩1)
next
case (Cons e h l v h' l' es es' h⇩2 l⇩2)
have "PROP ?P e h l (Val v) h' l' Vs ls" by fact
with Cons.prems
obtain ls' where 1: "?Post e h l (Val v) h' l' Vs ls ls'"
"size ls = size ls'" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?Ps es h' l' es' h⇩2 l⇩2 Vs ls'" by fact
with 1 Cons.prems
obtain ls⇩2 where 2: "?Posts es h' l' es' h⇩2 l⇩2 Vs ls' ls⇩2" by(auto)
from 1 2 Cons show ?case by(auto intro!:Cons⇩1)
next
case ConsThrow thus ?case
by(fastforce intro!:ConsThrow⇩1 dest: eval_final)
next
case (Block e h l V e' h' l' T)
let ?Vs = "Vs @ [V]"
have IH:
"⟦fv e ⊆ set ?Vs; l(V := None) ⊆⇩m [?Vs [↦] ls];
size ?Vs + max_vars e ≤ size ls⟧
⟹ ∃ls'. compP⇩1 P ⊢⇩1 ⟨compE⇩1 ?Vs e,(h,ls)⟩ ⇒ ⟨fin⇩1 e',(h', ls')⟩ ∧
l' ⊆⇩m [?Vs [↦] ls']" and
fv: "fv {V:T; e} ⊆ set Vs" and rel: "l ⊆⇩m [Vs [↦] ls]" and
len: "length Vs + max_vars {V:T; e} ≤ length ls" by fact+
have len': "length Vs < length ls" using len by auto
have "fv e ⊆ set ?Vs" using fv by auto
moreover have "l(V := None) ⊆⇩m [?Vs [↦] ls]" using rel len' by simp
moreover have "size ?Vs + max_vars e ≤ size ls" using len by simp
ultimately obtain ls' where
1: "compP⇩1 P ⊢⇩1 ⟨compE⇩1 ?Vs e,(h,ls)⟩ ⇒ ⟨fin⇩1 e',(h',ls')⟩"
and rel': "l' ⊆⇩m [?Vs [↦] ls']" using IH by blast
have [simp]: "length ls = length ls'" by(rule eval⇩1_preserves_len[OF 1])
show "∃ls'. compP⇩1 P ⊢⇩1 ⟨compE⇩1 Vs {V:T; e},(h,ls)⟩ ⇒ ⟨fin⇩1 e',(h',ls')⟩
∧ l'(V := l V) ⊆⇩m [Vs [↦] ls']" (is "∃ls'. ?R ls'")
proof
show "?R ls'"
proof
show "compP⇩1 P ⊢⇩1 ⟨compE⇩1 Vs {V:T; e},(h,ls)⟩ ⇒ ⟨fin⇩1 e',(h',ls')⟩"
using 1 by(simp add:Block⇩1)
next
show "l'(V := l V) ⊆⇩m [Vs [↦] ls']"
proof -
have "l' ⊆⇩m [Vs [↦] ls', V ↦ ls' ! length Vs]"
using len' rel' by simp
moreover
{ assume VinVs: "V ∈ set Vs"
hence "hidden (Vs @ [V]) (last_index Vs V)"
by(rule hidden_last_index)
hence "unmod (compE⇩1 (Vs @ [V]) e) (last_index Vs V)"
by(rule hidden_unmod)
moreover have "last_index Vs V < length ls"
using len' VinVs by simp
ultimately have "ls ! last_index Vs V = ls' ! last_index Vs V"
by(rule eval⇩1_preserves_unmod[OF 1])
}
ultimately show ?thesis using Block_lem[OF rel] len' by auto
qed
qed
qed
next
case (TryThrow e' h l a h' l' D fs C V e⇩2)
have "PROP ?P e' h l (Throw a) h' l' Vs ls" by fact
with TryThrow.prems
obtain ls' where 1: "?Post e' h l (Throw a) h' l' Vs ls ls'" by(auto)
show ?case using 1 TryThrow.hyps by(auto intro!:eval⇩1_evals⇩1.TryThrow⇩1)
next
case (TryCatch e⇩1 h l a h⇩1 l⇩1 D fs C e⇩2 V e' h⇩2 l⇩2)
let ?e = "try e⇩1 catch(C V) e⇩2"
have IH⇩1: "⟦fv e⇩1 ⊆ set Vs; l ⊆⇩m [Vs [↦] ls];
size Vs + max_vars e⇩1 ≤ length ls⟧
⟹ ∃ls⇩1. compP⇩1 P ⊢⇩1 ⟨compE⇩1 Vs e⇩1,(h,ls)⟩ ⇒
⟨fin⇩1 (Throw a),(h⇩1,ls⇩1)⟩ ∧
l⇩1 ⊆⇩m [Vs [↦] ls⇩1]" and
fv: "fv ?e ⊆ set Vs" and
rel: "l ⊆⇩m [Vs [↦] ls]" and
len: "length Vs + max_vars ?e ≤ length ls" by fact+
have "fv e⇩1 ⊆ set Vs" using fv by auto
moreover have "length Vs + max_vars e⇩1 ≤ length ls" using len by(auto)
ultimately obtain ls⇩1 where
1: "compP⇩1 P ⊢⇩1 ⟨compE⇩1 Vs e⇩1,(h,ls)⟩ ⇒ ⟨Throw a,(h⇩1,ls⇩1)⟩"
and rel⇩1: "l⇩1 ⊆⇩m [Vs [↦] ls⇩1]" using IH⇩1 rel by fastforce
from 1 have [simp]: "size ls = size ls⇩1" by(rule eval⇩1_preserves_len)
let ?Vs = "Vs @ [V]" let ?ls = "(ls⇩1[size Vs:=Addr a])"
have IH⇩2: "⟦fv e⇩2 ⊆ set ?Vs; l⇩1(V ↦ Addr a) ⊆⇩m [?Vs [↦] ?ls];
length ?Vs + max_vars e⇩2 ≤ length ?ls⟧ ⟹ ∃ls⇩2.
compP⇩1 P ⊢⇩1 ⟨compE⇩1 ?Vs e⇩2,(h⇩1,?ls)⟩ ⇒ ⟨fin⇩1 e',(h⇩2, ls⇩2)⟩ ∧
l⇩2 ⊆⇩m [?Vs [↦] ls⇩2]" by fact
have len⇩1: "size Vs < size ls⇩1" using len by(auto)
have "fv e⇩2 ⊆ set ?Vs" using fv by auto
moreover have "l⇩1(V ↦ Addr a) ⊆⇩m [?Vs [↦] ?ls]" using rel⇩1 len⇩1 by simp
moreover have "length ?Vs + max_vars e⇩2 ≤ length ?ls" using len by(auto)
ultimately obtain ls⇩2 where
2: "compP⇩1 P ⊢⇩1 ⟨compE⇩1 ?Vs e⇩2,(h⇩1,?ls)⟩ ⇒ ⟨fin⇩1 e',(h⇩2, ls⇩2)⟩"
and rel⇩2: "l⇩2 ⊆⇩m [?Vs [↦] ls⇩2]" using IH⇩2 by blast
from 2 have [simp]: "size ls⇩1 = size ls⇩2"
by(fastforce dest: eval⇩1_preserves_len)
show "∃ls⇩2. compP⇩1 P ⊢⇩1 ⟨compE⇩1 Vs ?e,(h,ls)⟩ ⇒ ⟨fin⇩1 e',(h⇩2,ls⇩2)⟩ ∧
l⇩2(V := l⇩1 V) ⊆⇩m [Vs [↦] ls⇩2]" (is "∃ls⇩2. ?R ls⇩2")
proof
show "?R ls⇩2"
proof
have hp: "h⇩1 a = Some (D, fs)" by fact
have "P ⊢ D ≼⇧* C" by fact hence caught: "compP⇩1 P ⊢ D ≼⇧* C" by simp
from TryCatch⇩1[OF 1 _ caught len⇩1 2, OF hp]
show "compP⇩1 P ⊢⇩1 ⟨compE⇩1 Vs ?e,(h,ls)⟩ ⇒ ⟨fin⇩1 e',(h⇩2,ls⇩2)⟩" by simp
next
show "l⇩2(V := l⇩1 V) ⊆⇩m [Vs [↦] ls⇩2]"
proof -
have "l⇩2 ⊆⇩m [Vs [↦] ls⇩2, V ↦ ls⇩2 ! length Vs]"
using len⇩1 rel⇩2 by simp
moreover
{ assume VinVs: "V ∈ set Vs"
hence "hidden (Vs @ [V]) (last_index Vs V)" by(rule hidden_last_index)
hence "unmod (compE⇩1 (Vs @ [V]) e⇩2) (last_index Vs V)"
by(rule hidden_unmod)
moreover have "last_index Vs V < length ?ls"
using len⇩1 VinVs by simp
ultimately have "?ls ! last_index Vs V = ls⇩2 ! last_index Vs V"
by(rule eval⇩1_preserves_unmod[OF 2])
moreover have "last_index Vs V < size Vs" using VinVs by simp
ultimately have "ls⇩1 ! last_index Vs V = ls⇩2 ! last_index Vs V"
using len⇩1 by(simp del:size_last_index_conv)
}
ultimately show ?thesis using Block_lem[OF rel⇩1] len⇩1 by simp
qed
qed
qed
next
case Try thus ?case by(fastforce intro!:Try⇩1)
next
case Throw thus ?case by(fastforce intro!:Throw⇩1)
next
case ThrowNull thus ?case by(fastforce intro!:ThrowNull⇩1)
next
case ThrowThrow thus ?case by(fastforce intro!:ThrowThrow⇩1)
next
case (CondT e h l h⇩1 l⇩1 e⇩1 e' h⇩2 l⇩2 e⇩2)
have "PROP ?P e h l true h⇩1 l⇩1 Vs ls" by fact
with CondT.prems
obtain ls⇩1 where 1: "?Post e h l true h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P e⇩1 h⇩1 l⇩1 e' h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 CondT.prems
obtain ls⇩2 where 2: "?Post e⇩1 h⇩1 l⇩1 e' h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 show ?case by(auto intro!:CondT⇩1)
next
case (CondF e h l h⇩1 l⇩1 e⇩2 e' h⇩2 l⇩2 e⇩1 Vs ls)
have "PROP ?P e h l false h⇩1 l⇩1 Vs ls" by fact
with CondF.prems
obtain ls⇩1 where 1: "?Post e h l false h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P e⇩2 h⇩1 l⇩1 e' h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 CondF.prems
obtain ls⇩2 where 2: "?Post e⇩2 h⇩1 l⇩1 e' h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 show ?case by(auto intro!:CondF⇩1)
next
case CondThrow thus ?case by(fastforce intro!:CondThrow⇩1)
next
case (Seq e h l v h⇩1 l⇩1 e⇩1 e' h⇩2 l⇩2)
have "PROP ?P e h l (Val v) h⇩1 l⇩1 Vs ls" by fact
with Seq.prems
obtain ls⇩1 where 1: "?Post e h l (Val v) h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P e⇩1 h⇩1 l⇩1 e' h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 Seq.prems
obtain ls⇩2 where 2: "?Post e⇩1 h⇩1 l⇩1 e' h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 Seq show ?case by(auto intro!:Seq⇩1)
next
case SeqThrow thus ?case by(fastforce intro!:SeqThrow⇩1)
next
case WhileF thus ?case by(fastforce intro!:eval⇩1_evals⇩1.intros)
next
case (WhileT e h l h⇩1 l⇩1 c v h⇩2 l⇩2 e' h⇩3 l⇩3)
have "PROP ?P e h l true h⇩1 l⇩1 Vs ls" by fact
with WhileT.prems
obtain ls⇩1 where 1: "?Post e h l true h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P c h⇩1 l⇩1 (Val v) h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 WhileT.prems
obtain ls⇩2 where 2: "?Post c h⇩1 l⇩1 (Val v) h⇩2 l⇩2 Vs ls⇩1 ls⇩2"
"size ls⇩1 = size ls⇩2" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P (While (e) c) h⇩2 l⇩2 e' h⇩3 l⇩3 Vs ls⇩2" by fact
with 1 2 WhileT.prems
obtain ls⇩3 where 3: "?Post (While (e) c) h⇩2 l⇩2 e' h⇩3 l⇩3 Vs ls⇩2 ls⇩3" by(auto)
from 1 2 3 show ?case by(auto intro!:WhileT⇩1)
next
case (WhileBodyThrow e h l h⇩1 l⇩1 c e' h⇩2 l⇩2)
have "PROP ?P e h l true h⇩1 l⇩1 Vs ls" by fact
with WhileBodyThrow.prems
obtain ls⇩1 where 1: "?Post e h l true h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P c h⇩1 l⇩1 (throw e') h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 WhileBodyThrow.prems
obtain ls⇩2 where 2: "?Post c h⇩1 l⇩1 (throw e') h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by auto
from 1 2 show ?case by(auto intro!:WhileBodyThrow⇩1)
next
case WhileCondThrow thus ?case by(fastforce intro!:WhileCondThrow⇩1)
next
case New thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case NewFail thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case Cast thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case CastNull thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case CastThrow thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case (CastFail e h l a h⇩1 l⇩1 D fs C)
have "PROP ?P e h l (addr a) h⇩1 l⇩1 Vs ls" by fact
with CastFail.prems
obtain ls⇩1 where 1: "?Post e h l (addr a) h⇩1 l⇩1 Vs ls ls⇩1" by auto
show ?case using 1 CastFail.hyps
by(auto intro!:CastFail⇩1[where D=D])
next
case Val thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case (BinOp e h l v⇩1 h⇩1 l⇩1 e⇩1 v⇩2 h⇩2 l⇩2 bop v)
have "PROP ?P e h l (Val v⇩1) h⇩1 l⇩1 Vs ls" by fact
with BinOp.prems
obtain ls⇩1 where 1: "?Post e h l (Val v⇩1) h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P e⇩1 h⇩1 l⇩1 (Val v⇩2) h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 BinOp.prems
obtain ls⇩2 where 2: "?Post e⇩1 h⇩1 l⇩1 (Val v⇩2) h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 BinOp show ?case by(auto intro!:BinOp⇩1)
next
case (BinOpThrow2 e⇩0 h l v⇩1 h⇩1 l⇩1 e⇩1 e h⇩2 l⇩2 bop)
have "PROP ?P e⇩0 h l (Val v⇩1) h⇩1 l⇩1 Vs ls" by fact
with BinOpThrow2.prems
obtain ls⇩1 where 1: "?Post e⇩0 h l (Val v⇩1) h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P e⇩1 h⇩1 l⇩1 (throw e) h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 BinOpThrow2.prems
obtain ls⇩2 where 2: "?Post e⇩1 h⇩1 l⇩1 (throw e) h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 BinOpThrow2 show ?case by(auto intro!:BinOpThrow⇩2⇩1)
next
case BinOpThrow1 thus ?case by(fastforce intro!:eval⇩1_evals⇩1.intros)
next
case Var thus ?case
by(force intro!:Var⇩1 simp add: map_le_def fun_upds_apply)
next
case LAss thus ?case
by(fastforce simp add: LAss_lem intro:eval⇩1_evals⇩1.intros
dest:eval⇩1_preserves_len)
next
case LAssThrow thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case FAcc thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case FAccNull thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case FAccThrow thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case (FAss e⇩1 h l a h⇩1 l⇩1 e⇩2 v h⇩2 l⇩2 C fs fs' F D h⇩2')
have "PROP ?P e⇩1 h l (addr a) h⇩1 l⇩1 Vs ls" by fact
with FAss.prems
obtain ls⇩1 where 1: "?Post e⇩1 h l (addr a) h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P e⇩2 h⇩1 l⇩1 (Val v) h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 FAss.prems
obtain ls⇩2 where 2: "?Post e⇩2 h⇩1 l⇩1 (Val v) h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 FAss show ?case by(auto intro!:FAss⇩1)
next
case (FAssNull e⇩1 h l h⇩1 l⇩1 e⇩2 v h⇩2 l⇩2 F D)
have "PROP ?P e⇩1 h l null h⇩1 l⇩1 Vs ls" by fact
with FAssNull.prems
obtain ls⇩1 where 1: "?Post e⇩1 h l null h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P e⇩2 h⇩1 l⇩1 (Val v) h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 FAssNull.prems
obtain ls⇩2 where 2: "?Post e⇩2 h⇩1 l⇩1 (Val v) h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 FAssNull show ?case by(auto intro!:FAssNull⇩1)
next
case FAssThrow1 thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case (FAssThrow2 e⇩1 h l v h⇩1 l⇩1 e⇩2 e h⇩2 l⇩2 F D)
have "PROP ?P e⇩1 h l (Val v) h⇩1 l⇩1 Vs ls" by fact
with FAssThrow2.prems
obtain ls⇩1 where 1: "?Post e⇩1 h l (Val v) h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?P e⇩2 h⇩1 l⇩1 (throw e) h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 FAssThrow2.prems
obtain ls⇩2 where 2: "?Post e⇩2 h⇩1 l⇩1 (throw e) h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 FAssThrow2 show ?case by(auto intro!:FAssThrow⇩2⇩1)
next
case (CallNull e h l h⇩1 l⇩1 es vs h⇩2 l⇩2 M)
have "PROP ?P e h l null h⇩1 l⇩1 Vs ls" by fact
with CallNull.prems
obtain ls⇩1 where 1: "?Post e h l null h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?Ps es h⇩1 l⇩1 (map Val vs) h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 CallNull.prems
obtain ls⇩2 where 2: "?Posts es h⇩1 l⇩1 (map Val vs) h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 CallNull show ?case
by (auto simp add: comp_def elim!: CallNull⇩1)
next
case CallObjThrow thus ?case by(fastforce intro:eval⇩1_evals⇩1.intros)
next
case (CallParamsThrow e h l v h⇩1 l⇩1 es vs ex es' h⇩2 l⇩2 M)
have "PROP ?P e h l (Val v) h⇩1 l⇩1 Vs ls" by fact
with CallParamsThrow.prems
obtain ls⇩1 where 1: "?Post e h l (Val v) h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?Ps es h⇩1 l⇩1 (map Val vs @ throw ex # es') h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 CallParamsThrow.prems
obtain ls⇩2 where 2: "?Posts es h⇩1 l⇩1 (map Val vs @ throw ex # es') h⇩2 l⇩2 Vs ls⇩1 ls⇩2" by(auto)
from 1 2 CallParamsThrow show ?case
by (auto simp add: comp_def
elim!: CallParamsThrow⇩1 dest!:evals_final)
next
case (Call e h l a h⇩1 l⇩1 es vs h⇩2 l⇩2 C fs M Ts T pns body D l⇩2' b' h⇩3 l⇩3)
have "PROP ?P e h l (addr a) h⇩1 l⇩1 Vs ls" by fact
with Call.prems
obtain ls⇩1 where 1: "?Post e h l (addr a) h⇩1 l⇩1 Vs ls ls⇩1"
"size ls = size ls⇩1" by(auto intro!:eval⇩1_preserves_len)
have "PROP ?Ps es h⇩1 l⇩1 (map Val vs) h⇩2 l⇩2 Vs ls⇩1" by fact
with 1 Call.prems
obtain ls⇩2 where 2: "?Posts es h⇩1 l⇩1 (map Val vs) h⇩2 l⇩2 Vs ls⇩1 ls⇩2"
"size ls⇩1 = size ls⇩2" by(auto intro!:evals⇩1_preserves_len)
let ?Vs = "this#pns"
let ?ls = "Addr a # vs @ replicate (max_vars body) undefined"
have mdecl: "P ⊢ C sees M: Ts→T = (pns, body) in D" by fact
have fv_body: "fv body ⊆ set ?Vs" and wf_size: "size Ts = size pns"
using wf mdecl by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
have mdecl⇩1: "compP⇩1 P ⊢ C sees M: Ts→T = (compE⇩1 ?Vs body) in D"
using sees_method_compP[OF mdecl, of "λ(pns,e). compE⇩1 (this#pns) e"]
by(simp)
have [simp]: "l⇩2' = [this ↦ Addr a, pns [↦] vs]" by fact
have Call_size: "size vs = size pns" by fact
have "PROP ?P body h⇩2 l⇩2' b' h⇩3 l⇩3 ?Vs ?ls" by fact
with 1 2 fv_body Call_size Call.prems
obtain ls⇩3 where 3: "?Post body h⇩2 l⇩2' b' h⇩3 l⇩3 ?Vs ?ls ls⇩3" by(auto)
have hp: "h⇩2 a = Some (C, fs)" by fact
from 1 2 3 hp mdecl⇩1 wf_size Call_size show ?case
by(fastforce simp add: comp_def
intro!: Call⇩1 dest!:evals_final)
qed
subsection‹Preservation of well-formedness›
text‹The compiler preserves well-formedness. Is less trivial than it
may appear. We start with two simple properties: preservation of
well-typedness›
lemma compE⇩1_pres_wt: "⋀Vs Ts U.
⟦ P,[Vs[↦]Ts] ⊢ e :: U; size Ts = size Vs ⟧
⟹ compP f P,Ts ⊢⇩1 compE⇩1 Vs e :: U"
and "⋀Vs Ts Us.
⟦ P,[Vs[↦]Ts] ⊢ es [::] Us; size Ts = size Vs ⟧
⟹ compP f P,Ts ⊢⇩1 compEs⇩1 Vs es [::] Us"
apply(induct e and es rule: compE⇩1.induct compEs⇩1.induct)
apply clarsimp
apply(fastforce)
apply clarsimp
apply(fastforce split:bop.splits)
apply (fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
apply (fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
apply (fastforce)
apply (fastforce)
apply (fastforce dest!: sees_method_compP[where f = f])
apply (fastforce simp:nth_append)
apply (fastforce)
apply (fastforce)
apply (fastforce)
apply (fastforce)
apply (fastforce simp:nth_append)
apply simp
apply (fastforce)
done
text‹\noindent and the correct block numbering:›
lemma ℬ: "⋀Vs n. size Vs = n ⟹ ℬ (compE⇩1 Vs e) n"
and ℬs: "⋀Vs n. size Vs = n ⟹ ℬs (compEs⇩1 Vs es) n"
apply (induction e and es rule: ℬ.induct ℬs.induct)
apply (auto dest: sym)
apply (metis length_append_singleton)
apply (metis length_append_singleton)
done
text‹The main complication is preservation of definite assignment
@{term"𝒟"}.›
lemma image_last_index: "A ⊆ set(xs@[x]) ⟹ last_index (xs @ [x]) ` A =
(if x ∈ A then insert (size xs) (last_index xs ` (A-{x})) else last_index xs ` A)"
by(auto simp:image_def)
lemma A_compE⇩1_None[simp]:
"⋀Vs. 𝒜 e = None ⟹ 𝒜 (compE⇩1 Vs e) = None"
and "⋀Vs. 𝒜s es = None ⟹ 𝒜s (compEs⇩1 Vs es) = None"
by(induct e and es rule: compE⇩1.induct compEs⇩1.induct)(auto simp:hyperset_defs)
lemma A_compE⇩1:
"⋀A Vs. ⟦ 𝒜 e = ⌊A⌋; fv e ⊆ set Vs ⟧ ⟹ 𝒜 (compE⇩1 Vs e) = ⌊last_index Vs ` A⌋"
and "⋀A Vs. ⟦ 𝒜s es = ⌊A⌋; fvs es ⊆ set Vs ⟧ ⟹ 𝒜s (compEs⇩1 Vs es) = ⌊last_index Vs ` A⌋"
proof(induct e and es rule: fv.induct fvs.induct)
case (Block V' T e)
hence "fv e ⊆ set (Vs@[V'])" by fastforce
moreover obtain B where "𝒜 e = ⌊B⌋"
using Block.prems by(simp add: hyperset_defs)
moreover from calculation have "B ⊆ set (Vs@[V'])" by(auto dest!:A_fv)
ultimately show ?case using Block
by(auto simp add: hyperset_defs image_last_index last_index_size_conv)
next
case (TryCatch e⇩1 C V' e⇩2)
hence fve⇩2: "fv e⇩2 ⊆ set (Vs@[V'])" by auto
show ?case
proof (cases "𝒜 e⇩1")
assume A⇩1: "𝒜 e⇩1 = None"
then obtain A⇩2 where A⇩2: "𝒜 e⇩2 = ⌊A⇩2⌋" using TryCatch
by(simp add:hyperset_defs)
hence "A⇩2 ⊆ set (Vs@[V'])" using TryCatch.prems A_fv[OF A⇩2] by simp blast
thus ?thesis using TryCatch fve⇩2 A⇩1 A⇩2
by(auto simp add:hyperset_defs image_last_index last_index_size_conv)
next
fix A⇩1 assume A⇩1: "𝒜 e⇩1 = ⌊A⇩1⌋"
show ?thesis
proof (cases "𝒜 e⇩2")
assume A⇩2: "𝒜 e⇩2 = None"
then show ?case using TryCatch A⇩1 by(simp add:hyperset_defs)
next
fix A⇩2 assume A⇩2: "𝒜 e⇩2 = ⌊A⇩2⌋"
have "A⇩1 ⊆ set Vs" using TryCatch.prems A_fv[OF A⇩1] by simp blast
moreover
have "A⇩2 ⊆ set (Vs@[V'])" using TryCatch.prems A_fv[OF A⇩2] by simp blast
ultimately show ?thesis using TryCatch A⇩1 A⇩2
by (auto simp add: Diff_subset_conv last_index_size_conv subsetD hyperset_defs dest!: sym [of _ A])
qed
qed
next
case (Cond e e⇩1 e⇩2)
{ assume "𝒜 e = None ∨ 𝒜 e⇩1 = None ∨ 𝒜 e⇩2 = None"
hence ?case using Cond by (auto simp add: hyperset_defs)
}
moreover
{ fix A A⇩1 A⇩2
assume "𝒜 e = ⌊A⌋" and A⇩1: "𝒜 e⇩1 = ⌊A⇩1⌋" and A⇩2: "𝒜 e⇩2 = ⌊A⇩2⌋"
moreover
have "A⇩1 ⊆ set Vs" using Cond.prems A_fv[OF A⇩1] by simp blast
moreover
have "A⇩2 ⊆ set Vs" using Cond.prems A_fv[OF A⇩2] by simp blast
ultimately have ?case using Cond
by(auto simp add:hyperset_defs image_Un
inj_on_image_Int[OF inj_on_last_index])
}
ultimately show ?case by fastforce
qed (auto simp add:hyperset_defs)
lemma D_None[iff]: "𝒟 (e::'a exp) None" and [iff]: "𝒟s (es::'a exp list) None"
by(induct e and es rule: 𝒟.induct 𝒟s.induct)(simp_all)
lemma D_last_index_compE⇩1:
"⋀A Vs. ⟦ A ⊆ set Vs; fv e ⊆ set Vs ⟧ ⟹
𝒟 e ⌊A⌋ ⟹ 𝒟 (compE⇩1 Vs e) ⌊last_index Vs ` A⌋"
and "⋀A Vs. ⟦ A ⊆ set Vs; fvs es ⊆ set Vs ⟧ ⟹
𝒟s es ⌊A⌋ ⟹ 𝒟s (compEs⇩1 Vs es) ⌊last_index Vs ` A⌋"
proof(induct e and es rule: 𝒟.induct 𝒟s.induct)
case (BinOp e⇩1 bop e⇩2)
hence IH⇩1: "𝒟 (compE⇩1 Vs e⇩1) ⌊last_index Vs ` A⌋" by simp
show ?case
proof (cases "𝒜 e⇩1")
case None thus ?thesis using BinOp by simp
next
case (Some A⇩1)
have indexA⇩1: "𝒜 (compE⇩1 Vs e⇩1) = ⌊last_index Vs ` A⇩1⌋"
using A_compE⇩1[OF Some] BinOp.prems by auto
have "A ∪ A⇩1 ⊆ set Vs" using BinOp.prems A_fv[OF Some] by auto
hence "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` (A ∪ A⇩1)⌋" using BinOp Some by auto
hence "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` A ∪ last_index Vs ` A⇩1⌋"
by(simp add: image_Un)
thus ?thesis using IH⇩1 indexA⇩1 by auto
qed
next
case (FAss e⇩1 F D e⇩2)
hence IH⇩1: "𝒟 (compE⇩1 Vs e⇩1) ⌊last_index Vs ` A⌋" by simp
show ?case
proof (cases "𝒜 e⇩1")
case None thus ?thesis using FAss by simp
next
case (Some A⇩1)
have indexA⇩1: "𝒜 (compE⇩1 Vs e⇩1) = ⌊last_index Vs ` A⇩1⌋"
using A_compE⇩1[OF Some] FAss.prems by auto
have "A ∪ A⇩1 ⊆ set Vs" using FAss.prems A_fv[OF Some] by auto
hence "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` (A ∪ A⇩1)⌋" using FAss Some by auto
hence "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` A ∪ last_index Vs ` A⇩1⌋"
by(simp add: image_Un)
thus ?thesis using IH⇩1 indexA⇩1 by auto
qed
next
case (Call e⇩1 M es)
hence IH⇩1: "𝒟 (compE⇩1 Vs e⇩1) ⌊last_index Vs ` A⌋" by simp
show ?case
proof (cases "𝒜 e⇩1")
case None thus ?thesis using Call by simp
next
case (Some A⇩1)
have indexA⇩1: "𝒜 (compE⇩1 Vs e⇩1) = ⌊last_index Vs ` A⇩1⌋"
using A_compE⇩1[OF Some] Call.prems by auto
have "A ∪ A⇩1 ⊆ set Vs" using Call.prems A_fv[OF Some] by auto
hence "𝒟s (compEs⇩1 Vs es) ⌊last_index Vs ` (A ∪ A⇩1)⌋" using Call Some by auto
hence "𝒟s (compEs⇩1 Vs es) ⌊last_index Vs ` A ∪ last_index Vs ` A⇩1⌋"
by(simp add: image_Un)
thus ?thesis using IH⇩1 indexA⇩1 by auto
qed
next
case (TryCatch e⇩1 C V e⇩2)
have "⟦ A∪{V} ⊆ set(Vs@[V]); fv e⇩2 ⊆ set(Vs@[V]); 𝒟 e⇩2 ⌊A∪{V}⌋⟧ ⟹
𝒟 (compE⇩1 (Vs@[V]) e⇩2) ⌊last_index (Vs@[V]) ` (A∪{V})⌋" by fact
hence "𝒟 (compE⇩1 (Vs@[V]) e⇩2) ⌊last_index (Vs@[V]) ` (A∪{V})⌋"
using TryCatch.prems by(simp add:Diff_subset_conv)
moreover have "last_index (Vs@[V]) ` A ⊆ last_index Vs ` A ∪ {size Vs}"
using TryCatch.prems by(auto simp add: image_last_index split:if_split_asm)
ultimately show ?case using TryCatch
by(auto simp:hyperset_defs elim!:D_mono')
next
case (Seq e⇩1 e⇩2)
hence IH⇩1: "𝒟 (compE⇩1 Vs e⇩1) ⌊last_index Vs ` A⌋" by simp
show ?case
proof (cases "𝒜 e⇩1")
case None thus ?thesis using Seq by simp
next
case (Some A⇩1)
have indexA⇩1: "𝒜 (compE⇩1 Vs e⇩1) = ⌊last_index Vs ` A⇩1⌋"
using A_compE⇩1[OF Some] Seq.prems by auto
have "A ∪ A⇩1 ⊆ set Vs" using Seq.prems A_fv[OF Some] by auto
hence "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` (A ∪ A⇩1)⌋" using Seq Some by auto
hence "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` A ∪ last_index Vs ` A⇩1⌋"
by(simp add: image_Un)
thus ?thesis using IH⇩1 indexA⇩1 by auto
qed
next
case (Cond e e⇩1 e⇩2)
hence IH⇩1: "𝒟 (compE⇩1 Vs e) ⌊last_index Vs ` A⌋" by simp
show ?case
proof (cases "𝒜 e")
case None thus ?thesis using Cond by simp
next
case (Some B)
have indexB: "𝒜 (compE⇩1 Vs e) = ⌊last_index Vs ` B⌋"
using A_compE⇩1[OF Some] Cond.prems by auto
have "A ∪ B ⊆ set Vs" using Cond.prems A_fv[OF Some] by auto
hence "𝒟 (compE⇩1 Vs e⇩1) ⌊last_index Vs ` (A ∪ B)⌋"
and "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` (A ∪ B)⌋"
using Cond Some by auto
hence "𝒟 (compE⇩1 Vs e⇩1) ⌊last_index Vs ` A ∪ last_index Vs ` B⌋"
and "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` A ∪ last_index Vs ` B⌋"
by(simp add: image_Un)+
thus ?thesis using IH⇩1 indexB by auto
qed
next
case (While e⇩1 e⇩2)
hence IH⇩1: "𝒟 (compE⇩1 Vs e⇩1) ⌊last_index Vs ` A⌋" by simp
show ?case
proof (cases "𝒜 e⇩1")
case None thus ?thesis using While by simp
next
case (Some A⇩1)
have indexA⇩1: "𝒜 (compE⇩1 Vs e⇩1) = ⌊last_index Vs ` A⇩1⌋"
using A_compE⇩1[OF Some] While.prems by auto
have "A ∪ A⇩1 ⊆ set Vs" using While.prems A_fv[OF Some] by auto
hence "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` (A ∪ A⇩1)⌋" using While Some by auto
hence "𝒟 (compE⇩1 Vs e⇩2) ⌊last_index Vs ` A ∪ last_index Vs ` A⇩1⌋"
by(simp add: image_Un)
thus ?thesis using IH⇩1 indexA⇩1 by auto
qed
next
case (Block V T e)
have "⟦ A-{V} ⊆ set(Vs@[V]); fv e ⊆ set(Vs@[V]); 𝒟 e ⌊A-{V}⌋ ⟧ ⟹
𝒟 (compE⇩1 (Vs@[V]) e) ⌊last_index (Vs@[V]) ` (A-{V})⌋" by fact
hence "𝒟 (compE⇩1 (Vs@[V]) e) ⌊last_index (Vs@[V]) ` (A-{V})⌋"
using Block.prems by(simp add:Diff_subset_conv)
moreover have "size Vs ∉ last_index Vs ` A"
using Block.prems by(auto simp add:image_def size_last_index_conv)
ultimately show ?case using Block
by(auto simp add: image_last_index Diff_subset_conv hyperset_defs elim!: D_mono')
next
case (Cons_exp e⇩1 es)
hence IH⇩1: "𝒟 (compE⇩1 Vs e⇩1) ⌊last_index Vs ` A⌋" by simp
show ?case
proof (cases "𝒜 e⇩1")
case None thus ?thesis using Cons_exp by simp
next
case (Some A⇩1)
have indexA⇩1: "𝒜 (compE⇩1 Vs e⇩1) = ⌊last_index Vs ` A⇩1⌋"
using A_compE⇩1[OF Some] Cons_exp.prems by auto
have "A ∪ A⇩1 ⊆ set Vs" using Cons_exp.prems A_fv[OF Some] by auto
hence "𝒟s (compEs⇩1 Vs es) ⌊last_index Vs ` (A ∪ A⇩1)⌋" using Cons_exp Some by auto
hence "𝒟s (compEs⇩1 Vs es) ⌊last_index Vs ` A ∪ last_index Vs ` A⇩1⌋"
by(simp add: image_Un)
thus ?thesis using IH⇩1 indexA⇩1 by auto
qed
qed (simp_all add:hyperset_defs)
lemma last_index_image_set: "distinct xs ⟹ last_index xs ` set xs = {..<size xs}"
by(induct xs rule:rev_induct) (auto simp add: image_last_index)
lemma D_compE⇩1:
"⟦ 𝒟 e ⌊set Vs⌋; fv e ⊆ set Vs; distinct Vs ⟧ ⟹ 𝒟 (compE⇩1 Vs e) ⌊{..<length Vs}⌋"
by(fastforce dest!: D_last_index_compE⇩1[OF subset_refl] simp add:last_index_image_set)
lemma D_compE⇩1':
assumes "𝒟 e ⌊set(V#Vs)⌋" and "fv e ⊆ set(V#Vs)" and "distinct(V#Vs)"
shows "𝒟 (compE⇩1 (V#Vs) e) ⌊{..length Vs}⌋"
proof -
have "{..size Vs} = {..<size(V#Vs)}" by auto
thus ?thesis using assms by (simp only:)(rule D_compE⇩1)
qed
lemma compP⇩1_pres_wf: "wf_J_prog P ⟹ wf_J⇩1_prog (compP⇩1 P)"
apply simp
apply(rule wf_prog_compPI)
prefer 2 apply assumption
apply(case_tac m)
apply(simp add:wf_mdecl_def wf_J⇩1_mdecl_def wf_J_mdecl)
apply(clarify)
apply(frule WT_fv)
apply(fastforce intro!: compE⇩1_pres_wt D_compE⇩1' ℬ)
done
end
Theory Compiler2
section ‹Compilation Stage 2›
theory Compiler2
imports PCompiler J1 "../JVM/JVMExec"
begin
primrec compE⇩2 :: "expr⇩1 ⇒ instr list"
and compEs⇩2 :: "expr⇩1 list ⇒ instr list" where
"compE⇩2 (new C) = [New C]"
| "compE⇩2 (Cast C e) = compE⇩2 e @ [Checkcast C]"
| "compE⇩2 (Val v) = [Push v]"
| "compE⇩2 (e⇩1 «bop» e⇩2) = compE⇩2 e⇩1 @ compE⇩2 e⇩2 @
(case bop of Eq ⇒ [CmpEq]
| Add ⇒ [IAdd])"
| "compE⇩2 (Var i) = [Load i]"
| "compE⇩2 (i:=e) = compE⇩2 e @ [Store i, Push Unit]"
| "compE⇩2 (e∙F{D}) = compE⇩2 e @ [Getfield F D]"
| "compE⇩2 (e⇩1∙F{D} := e⇩2) =
compE⇩2 e⇩1 @ compE⇩2 e⇩2 @ [Putfield F D, Push Unit]"
| "compE⇩2 (e∙M(es)) = compE⇩2 e @ compEs⇩2 es @ [Invoke M (size es)]"
| "compE⇩2 ({i:T; e}) = compE⇩2 e"
| "compE⇩2 (e⇩1;;e⇩2) = compE⇩2 e⇩1 @ [Pop] @ compE⇩2 e⇩2"
| "compE⇩2 (if (e) e⇩1 else e⇩2) =
(let cnd = compE⇩2 e;
thn = compE⇩2 e⇩1;
els = compE⇩2 e⇩2;
test = IfFalse (int(size thn + 2));
thnex = Goto (int(size els + 1))
in cnd @ [test] @ thn @ [thnex] @ els)"
| "compE⇩2 (while (e) c) =
(let cnd = compE⇩2 e;
bdy = compE⇩2 c;
test = IfFalse (int(size bdy + 3));
loop = Goto (-int(size bdy + size cnd + 2))
in cnd @ [test] @ bdy @ [Pop] @ [loop] @ [Push Unit])"
| "compE⇩2 (throw e) = compE⇩2 e @ [instr.Throw]"
| "compE⇩2 (try e⇩1 catch(C i) e⇩2) =
(let catch = compE⇩2 e⇩2
in compE⇩2 e⇩1 @ [Goto (int(size catch)+2), Store i] @ catch)"
| "compEs⇩2 [] = []"
| "compEs⇩2 (e#es) = compE⇩2 e @ compEs⇩2 es"
text‹Compilation of exception table. Is given start address of code
to compute absolute addresses necessary in exception table.›
primrec compxE⇩2 :: "expr⇩1 ⇒ pc ⇒ nat ⇒ ex_table"
and compxEs⇩2 :: "expr⇩1 list ⇒ pc ⇒ nat ⇒ ex_table" where
"compxE⇩2 (new C) pc d = []"
| "compxE⇩2 (Cast C e) pc d = compxE⇩2 e pc d"
| "compxE⇩2 (Val v) pc d = []"
| "compxE⇩2 (e⇩1 «bop» e⇩2) pc d =
compxE⇩2 e⇩1 pc d @ compxE⇩2 e⇩2 (pc + size(compE⇩2 e⇩1)) (d+1)"
| "compxE⇩2 (Var i) pc d = []"
| "compxE⇩2 (i:=e) pc d = compxE⇩2 e pc d"
| "compxE⇩2 (e∙F{D}) pc d = compxE⇩2 e pc d"
| "compxE⇩2 (e⇩1∙F{D} := e⇩2) pc d =
compxE⇩2 e⇩1 pc d @ compxE⇩2 e⇩2 (pc + size(compE⇩2 e⇩1)) (d+1)"
| "compxE⇩2 (e∙M(es)) pc d =
compxE⇩2 e pc d @ compxEs⇩2 es (pc + size(compE⇩2 e)) (d+1)"
| "compxE⇩2 ({i:T; e}) pc d = compxE⇩2 e pc d"
| "compxE⇩2 (e⇩1;;e⇩2) pc d =
compxE⇩2 e⇩1 pc d @ compxE⇩2 e⇩2 (pc+size(compE⇩2 e⇩1)+1) d"
| "compxE⇩2 (if (e) e⇩1 else e⇩2) pc d =
(let pc⇩1 = pc + size(compE⇩2 e) + 1;
pc⇩2 = pc⇩1 + size(compE⇩2 e⇩1) + 1
in compxE⇩2 e pc d @ compxE⇩2 e⇩1 pc⇩1 d @ compxE⇩2 e⇩2 pc⇩2 d)"
| "compxE⇩2 (while (b) e) pc d =
compxE⇩2 b pc d @ compxE⇩2 e (pc+size(compE⇩2 b)+1) d"
| "compxE⇩2 (throw e) pc d = compxE⇩2 e pc d"
| "compxE⇩2 (try e⇩1 catch(C i) e⇩2) pc d =
(let pc⇩1 = pc + size(compE⇩2 e⇩1)
in compxE⇩2 e⇩1 pc d @ compxE⇩2 e⇩2 (pc⇩1+2) d @ [(pc,pc⇩1,C,pc⇩1+1,d)])"
| "compxEs⇩2 [] pc d = []"
| "compxEs⇩2 (e#es) pc d = compxE⇩2 e pc d @ compxEs⇩2 es (pc+size(compE⇩2 e)) (d+1)"
primrec max_stack :: "expr⇩1 ⇒ nat"
and max_stacks :: "expr⇩1 list ⇒ nat" where
"max_stack (new C) = 1"
| "max_stack (Cast C e) = max_stack e"
| "max_stack (Val v) = 1"
| "max_stack (e⇩1 «bop» e⇩2) = max (max_stack e⇩1) (max_stack e⇩2) + 1"
| "max_stack (Var i) = 1"
| "max_stack (i:=e) = max_stack e"
| "max_stack (e∙F{D}) = max_stack e"
| "max_stack (e⇩1∙F{D} := e⇩2) = max (max_stack e⇩1) (max_stack e⇩2) + 1"
| "max_stack (e∙M(es)) = max (max_stack e) (max_stacks es) + 1"
| "max_stack ({i:T; e}) = max_stack e"
| "max_stack (e⇩1;;e⇩2) = max (max_stack e⇩1) (max_stack e⇩2)"
| "max_stack (if (e) e⇩1 else e⇩2) =
max (max_stack e) (max (max_stack e⇩1) (max_stack e⇩2))"
| "max_stack (while (e) c) = max (max_stack e) (max_stack c)"
| "max_stack (throw e) = max_stack e"
| "max_stack (try e⇩1 catch(C i) e⇩2) = max (max_stack e⇩1) (max_stack e⇩2)"
| "max_stacks [] = 0"
| "max_stacks (e#es) = max (max_stack e) (1 + max_stacks es)"
lemma max_stack1: "1 ≤ max_stack e"
by(induct e) (simp_all add:max_def)
definition compMb⇩2 :: "expr⇩1 ⇒ jvm_method"
where
"compMb⇩2 ≡ λbody.
let ins = compE⇩2 body @ [Return];
xt = compxE⇩2 body 0 0
in (max_stack body, max_vars body, ins, xt)"
definition compP⇩2 :: "J⇩1_prog ⇒ jvm_prog"
where
"compP⇩2 ≡ compP compMb⇩2"
declare compP⇩2_def [simp]
lemma compMb⇩2 [simp]:
"compMb⇩2 e = (max_stack e, max_vars e, compE⇩2 e @ [Return], compxE⇩2 e 0 0)"
by (simp add: compMb⇩2_def)
end
Theory Correctness2
section ‹Correctness of Stage 2›
theory Correctness2
imports "HOL-Library.Sublist" Compiler2
begin
hide_const (open) Throw
subsection‹Instruction sequences›
text‹How to select individual instructions and subsequences of
instructions from a program given the class, method and program
counter.›
definition before :: "jvm_prog ⇒ cname ⇒ mname ⇒ nat ⇒ instr list ⇒ bool"
("(_,_,_,_/ ⊳ _)" [51,0,0,0,51] 50) where
"P,C,M,pc ⊳ is ⟷ prefix is (drop pc (instrs_of P C M))"
definition at :: "jvm_prog ⇒ cname ⇒ mname ⇒ nat ⇒ instr ⇒ bool"
("(_,_,_,_/ ▹ _)" [51,0,0,0,51] 50) where
"P,C,M,pc ▹ i ⟷ (∃is. drop pc (instrs_of P C M) = i#is)"
lemma [simp]: "P,C,M,pc ⊳ []"
by(simp add:before_def)
lemma [simp]: "P,C,M,pc ⊳ (i#is) = (P,C,M,pc ▹ i ∧ P,C,M,pc + 1 ⊳ is)"
by(fastforce simp add:before_def at_def prefix_def drop_Suc drop_tl)
declare drop_drop[simp del]
lemma [simp]: "P,C,M,pc ⊳ (is⇩1 @ is⇩2) = (P,C,M,pc ⊳ is⇩1 ∧ P,C,M,pc + size is⇩1 ⊳ is⇩2)"
apply(simp add:before_def prefix_def)
apply(subst add.commute)
apply(simp add: drop_drop[symmetric])
apply fastforce
done
declare drop_drop[simp]
lemma [simp]: "P,C,M,pc ▹ i ⟹ instrs_of P C M ! pc = i"
by(clarsimp simp add:at_def strict_prefix_def nth_via_drop)
lemma beforeM:
"P ⊢ C sees M: Ts→T = body in D ⟹
compP⇩2 P,D,M,0 ⊳ compE⇩2 body @ [Return]"
apply(drule sees_method_idemp)
apply(simp add:before_def compP⇩2_def compMb⇩2_def)
done
text‹This lemma executes a single instruction by rewriting:›
lemma [simp]:
"P,C,M,pc ▹ instr ⟹
(P ⊢ (None, h, (vs,ls,C,M,pc) # frs) -jvm→ σ') =
((None, h, (vs,ls,C,M,pc) # frs) = σ' ∨
(∃σ. exec(P,(None, h, (vs,ls,C,M,pc) # frs)) = Some σ ∧ P ⊢ σ -jvm→ σ'))"
apply(simp only: exec_all_def)
apply(blast intro: converse_rtranclE converse_rtrancl_into_rtrancl)
done
subsection‹Exception tables›
definition pcs :: "ex_table ⇒ nat set"
where
"pcs xt ≡ ⋃(f,t,C,h,d) ∈ set xt. {f ..< t}"
lemma pcs_subset:
shows "⋀pc d. pcs(compxE⇩2 e pc d) ⊆ {pc..<pc+size(compE⇩2 e)}"
and "⋀pc d. pcs(compxEs⇩2 es pc d) ⊆ {pc..<pc+size(compEs⇩2 es)}"
apply(induct e and es rule: compxE⇩2.induct compxEs⇩2.induct)
apply (simp_all add:pcs_def)
apply (fastforce split:bop.splits)+
done
lemma [simp]: "pcs [] = {}"
by(simp add:pcs_def)
lemma [simp]: "pcs (x#xt) = {fst x ..< fst(snd x)} ∪ pcs xt"
by(auto simp add: pcs_def)
lemma [simp]: "pcs(xt⇩1 @ xt⇩2) = pcs xt⇩1 ∪ pcs xt⇩2"
by(simp add:pcs_def)
lemma [simp]: "pc < pc⇩0 ∨ pc⇩0+size(compE⇩2 e) ≤ pc ⟹ pc ∉ pcs(compxE⇩2 e pc⇩0 d)"
using pcs_subset by fastforce
lemma [simp]: "pc < pc⇩0 ∨ pc⇩0+size(compEs⇩2 es) ≤ pc ⟹ pc ∉ pcs(compxEs⇩2 es pc⇩0 d)"
using pcs_subset by fastforce
lemma [simp]: "pc⇩1 + size(compE⇩2 e⇩1) ≤ pc⇩2 ⟹ pcs(compxE⇩2 e⇩1 pc⇩1 d⇩1) ∩ pcs(compxE⇩2 e⇩2 pc⇩2 d⇩2) = {}"
using pcs_subset by fastforce
lemma [simp]: "pc⇩1 + size(compE⇩2 e) ≤ pc⇩2 ⟹ pcs(compxE⇩2 e pc⇩1 d⇩1) ∩ pcs(compxEs⇩2 es pc⇩2 d⇩2) = {}"
using pcs_subset by fastforce
lemma [simp]:
"pc ∉ pcs xt⇩0 ⟹ match_ex_table P C pc (xt⇩0 @ xt⇩1) = match_ex_table P C pc xt⇩1"
by (induct xt⇩0) (auto simp: matches_ex_entry_def)
lemma [simp]: "⟦ x ∈ set xt; pc ∉ pcs xt ⟧ ⟹ ¬ matches_ex_entry P D pc x"
by(auto simp:matches_ex_entry_def pcs_def)
lemma [simp]:
assumes xe: "xe ∈ set(compxE⇩2 e pc d)" and outside: "pc' < pc ∨ pc+size(compE⇩2 e) ≤ pc'"
shows "¬ matches_ex_entry P C pc' xe"
proof
assume "matches_ex_entry P C pc' xe"
with xe have "pc' ∈ pcs(compxE⇩2 e pc d)"
by(force simp add:matches_ex_entry_def pcs_def)
with outside show False by simp
qed
lemma [simp]:
assumes xe: "xe ∈ set(compxEs⇩2 es pc d)" and outside: "pc' < pc ∨ pc+size(compEs⇩2 es) ≤ pc'"
shows "¬ matches_ex_entry P C pc' xe"
proof
assume "matches_ex_entry P C pc' xe"
with xe have "pc' ∈ pcs(compxEs⇩2 es pc d)"
by(force simp add:matches_ex_entry_def pcs_def)
with outside show False by simp
qed
lemma match_ex_table_app[simp]:
"∀xte ∈ set xt⇩1. ¬ matches_ex_entry P D pc xte ⟹
match_ex_table P D pc (xt⇩1 @ xt) = match_ex_table P D pc xt"
by(induct xt⇩1) simp_all
lemma [simp]:
"∀x ∈ set xtab. ¬ matches_ex_entry P C pc x ⟹
match_ex_table P C pc xtab = None"
using match_ex_table_app[where ?xt = "[]"] by fastforce
lemma match_ex_entry:
"matches_ex_entry P C pc (start, end, catch_type, handler) =
(start ≤ pc ∧ pc < end ∧ P ⊢ C ≼⇧* catch_type)"
by(simp add:matches_ex_entry_def)
definition caught :: "jvm_prog ⇒ pc ⇒ heap ⇒ addr ⇒ ex_table ⇒ bool" where
"caught P pc h a xt ⟷
(∃entry ∈ set xt. matches_ex_entry P (cname_of h a) pc entry)"
definition beforex :: "jvm_prog ⇒ cname ⇒ mname ⇒ ex_table ⇒ nat set ⇒ nat ⇒ bool"
("(2_,/_,/_ ⊳/ _ /'/ _,/_)" [51,0,0,0,0,51] 50) where
"P,C,M ⊳ xt / I,d ⟷
(∃xt⇩0 xt⇩1. ex_table_of P C M = xt⇩0 @ xt @ xt⇩1 ∧ pcs xt⇩0 ∩ I = {} ∧ pcs xt ⊆ I ∧
(∀pc ∈ I. ∀C pc' d'. match_ex_table P C pc xt⇩1 = ⌊(pc',d')⌋ ⟶ d' ≤ d))"
definition dummyx :: "jvm_prog ⇒ cname ⇒ mname ⇒ ex_table ⇒ nat set ⇒ nat ⇒ bool" ("(2_,_,_ ▹/ _ '/_,_)" [51,0,0,0,0,51] 50) where
"P,C,M ▹ xt/I,d ⟷ P,C,M ⊳ xt/I,d"
lemma beforexD1: "P,C,M ⊳ xt / I,d ⟹ pcs xt ⊆ I"
by(auto simp add:beforex_def)
lemma beforex_mono: "⟦ P,C,M ⊳ xt/I,d'; d' ≤ d ⟧ ⟹ P,C,M ⊳ xt/I,d"
by(fastforce simp:beforex_def)
lemma [simp]: "P,C,M ⊳ xt/I,d ⟹ P,C,M ⊳ xt/I,Suc d"
by(fastforce intro:beforex_mono)
lemma beforex_append[simp]:
"pcs xt⇩1 ∩ pcs xt⇩2 = {} ⟹
P,C,M ⊳ xt⇩1 @ xt⇩2/I,d =
(P,C,M ⊳ xt⇩1/I-pcs xt⇩2,d ∧ P,C,M ⊳ xt⇩2/I-pcs xt⇩1,d ∧ P,C,M ▹ xt⇩1@xt⇩2/I,d)"
apply(rule iffI)
prefer 2
apply(simp add:dummyx_def)
apply(auto simp add: beforex_def dummyx_def)
apply(rule_tac x = xt⇩0 in exI)
apply auto
apply(rule_tac x = "xt⇩0@xt⇩1" in exI)
apply auto
done
lemma beforex_appendD1:
"⟦ P,C,M ⊳ xt⇩1 @ xt⇩2 @ [(f,t,D,h,d)] / I,d;
pcs xt⇩1 ⊆ J; J ⊆ I; J ∩ pcs xt⇩2 = {} ⟧
⟹ P,C,M ⊳ xt⇩1 / J,d"
apply(auto simp:beforex_def)
apply(rule exI,rule exI,rule conjI, rule refl)
apply(rule conjI, blast)
apply(auto)
apply(subgoal_tac "pc ∉ pcs xt⇩2")
prefer 2 apply blast
apply (auto split:if_split_asm)
done
lemma beforex_appendD2:
"⟦ P,C,M ⊳ xt⇩1 @ xt⇩2 @ [(f,t,D,h,d)] / I,d;
pcs xt⇩2 ⊆ J; J ⊆ I; J ∩ pcs xt⇩1 = {} ⟧
⟹ P,C,M ⊳ xt⇩2 / J,d"
apply(auto simp:beforex_def)
apply(rule_tac x = "xt⇩0 @ xt⇩1" in exI)
apply fastforce
done
lemma beforexM:
"P ⊢ C sees M: Ts→T = body in D ⟹
compP⇩2 P,D,M ⊳ compxE⇩2 body 0 0/{..<size(compE⇩2 body)},0"
apply(drule sees_method_idemp)
apply(drule sees_method_compP[where f = compMb⇩2])
apply(simp add:beforex_def compP⇩2_def compMb⇩2_def)
apply(rule_tac x = "[]" in exI)
using pcs_subset apply fastforce
done
lemma match_ex_table_SomeD2:
"⟦ match_ex_table P D pc (ex_table_of P C M) = ⌊(pc',d')⌋;
P,C,M ⊳ xt/I,d; ∀x ∈ set xt. ¬ matches_ex_entry P D pc x; pc ∈ I ⟧
⟹ d' ≤ d"
apply(auto simp:beforex_def)
apply(subgoal_tac "pc ∉ pcs xt⇩0")
apply auto
done
lemma match_ex_table_SomeD1:
"⟦ match_ex_table P D pc (ex_table_of P C M) = ⌊(pc',d')⌋;
P,C,M ⊳ xt / I,d; pc ∈ I; pc ∉ pcs xt ⟧ ⟹ d' ≤ d"
by(auto elim: match_ex_table_SomeD2)
subsection‹The correctness proof›
declare nat_add_distrib[simp] caught_def[simp]
declare fun_upd_apply[simp del]
definition
handle :: "jvm_prog ⇒ cname ⇒ mname ⇒ addr ⇒ heap ⇒ val list ⇒ val list ⇒ nat ⇒ frame list
⇒ jvm_state" where
"handle P C M a h vs ls pc frs = find_handler P a h ((vs,ls,C,M,pc) # frs)"
lemma handle_Cons:
"⟦ P,C,M ⊳ xt/I,d; d ≤ size vs; pc ∈ I;
∀x ∈ set xt. ¬ matches_ex_entry P (cname_of h xa) pc x ⟧ ⟹
handle P C M xa h (v # vs) ls pc frs = handle P C M xa h vs ls pc frs"
by(auto simp:handle_def Suc_diff_le dest: match_ex_table_SomeD2)
lemma handle_append:
"⟦ P,C,M ⊳ xt/I,d; d ≤ size vs; pc ∈ I; pc ∉ pcs xt ⟧ ⟹
handle P C M xa h (ws @ vs) ls pc frs = handle P C M xa h vs ls pc frs"
apply(auto simp:handle_def)
apply(rename_tac pc' d')
apply(subgoal_tac "size ws ≤ length ws + length vs - d'")
apply(simp add:drop_all)
apply(fastforce dest:match_ex_table_SomeD2 split:nat_diff_split)
done
lemma aux_isin[simp]: "⟦ B ⊆ A; a ∈ B ⟧ ⟹ a ∈ A"
by blast
lemma fixes P⇩1 defines [simp]: "P ≡ compP⇩2 P⇩1"
shows Jcc:
"P⇩1 ⊢⇩1 ⟨e,(h⇩0,ls⇩0)⟩ ⇒ ⟨ef,(h⇩1,ls⇩1)⟩ ⟹
(⋀C M pc v xa vs frs I.
⟦ P,C,M,pc ⊳ compE⇩2 e; P,C,M ⊳ compxE⇩2 e pc (size vs)/I,size vs;
{pc..<pc+size(compE⇩2 e)} ⊆ I ⟧ ⟹
(ef = Val v ⟶
P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(v#vs,ls⇩1,C,M,pc+size(compE⇩2 e))#frs))
∧
(ef = Throw xa ⟶
(∃pc⇩1. pc ≤ pc⇩1 ∧ pc⇩1 < pc + size(compE⇩2 e) ∧
¬ caught P pc⇩1 h⇩1 xa (compxE⇩2 e pc (size vs)) ∧
P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→ handle P C M xa h⇩1 vs ls⇩1 pc⇩1 frs)))"
(is "_ ⟹ (⋀C M pc v xa vs frs I.
PROP ?P e h⇩0 ls⇩0 ef h⇩1 ls⇩1 C M pc v xa vs frs I)")
and "P⇩1 ⊢⇩1 ⟨es,(h⇩0,ls⇩0)⟩ [⇒] ⟨fs,(h⇩1,ls⇩1)⟩ ⟹
(⋀C M pc ws xa es' vs frs I.
⟦ P,C,M,pc ⊳ compEs⇩2 es; P,C,M ⊳ compxEs⇩2 es pc (size vs)/I,size vs;
{pc..<pc+size(compEs⇩2 es)} ⊆ I ⟧ ⟹
(fs = map Val ws ⟶
P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(rev ws @ vs,ls⇩1,C,M,pc+size(compEs⇩2 es))#frs))
∧
(fs = map Val ws @ Throw xa # es' ⟶
(∃pc⇩1. pc ≤ pc⇩1 ∧ pc⇩1 < pc + size(compEs⇩2 es) ∧
¬ caught P pc⇩1 h⇩1 xa (compxEs⇩2 es pc (size vs)) ∧
P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→ handle P C M xa h⇩1 vs ls⇩1 pc⇩1 frs)))"
(is "_ ⟹ (⋀C M pc ws xa es' vs frs I.
PROP ?Ps es h⇩0 ls⇩0 fs h⇩1 ls⇩1 C M pc ws xa es' vs frs I)")
proof (induct rule:eval⇩1_evals⇩1_inducts)
case New⇩1 thus ?case by (clarsimp simp add:blank_def fun_eq_iff)
next
case NewFail⇩1 thus ?case by(auto simp: handle_def pcs_def)
next
case (Cast⇩1 e h⇩0 ls⇩0 a h⇩1 ls⇩1 D fs C')
let ?pc = "pc + length(compE⇩2 e)"
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(Addr a#vs,ls⇩1,C,M,?pc)#frs)" using Cast⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩1,(Addr a#vs,ls⇩1,C,M,?pc+1)#frs)"
using Cast⇩1 by (auto simp add:cast_ok_def)
finally show ?case by auto
next
case (CastNull⇩1 e h⇩0 ls⇩0 h⇩1 ls⇩1 C')
let ?pc = "pc + length(compE⇩2 e)"
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(Null#vs,ls⇩1,C,M,?pc)#frs)"
using CastNull⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩1,(Null#vs,ls⇩1,C,M,?pc+1)#frs)"
using CastNull⇩1 by (auto simp add:cast_ok_def)
finally show ?case by auto
next
case (CastFail⇩1 e h⇩0 ls⇩0 a h⇩1 ls⇩1 D fs C')
let ?pc = "pc + length(compE⇩2 e)"
let ?xa = "addr_of_sys_xcpt ClassCast"
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(Addr a#vs,ls⇩1,C,M,?pc)#frs)"
using CastFail⇩1 by fastforce
also have "P ⊢ … -jvm→ handle P C M ?xa h⇩1 (Addr a#vs) ls⇩1 ?pc frs"
using CastFail⇩1 by (auto simp add:handle_def cast_ok_def)
also have "handle P C M ?xa h⇩1 (Addr a#vs) ls⇩1 ?pc frs =
handle P C M ?xa h⇩1 vs ls⇩1 ?pc frs"
using CastFail⇩1.prems by(auto simp:handle_Cons)
finally have exec: "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→ …".
show ?case (is "?N ∧ (?eq ⟶ (∃pc⇩1. ?H pc⇩1))")
proof
show ?N by simp
next
have "?eq ⟶ ?H ?pc" using exec by auto
thus "?eq ⟶ (∃pc⇩1. ?H pc⇩1)" by blast
qed
next
case CastThrow⇩1 thus ?case by fastforce
next
case Val⇩1 thus ?case by simp
next
case Var⇩1 thus ?case by auto
next
case (BinOp⇩1 e⇩1 h⇩0 ls⇩0 v⇩1 h⇩1 ls⇩1 e⇩2 v⇩2 h⇩2 ls⇩2 bop w)
let ?pc⇩1 = "pc + length(compE⇩2 e⇩1)"
let ?pc⇩2 = "?pc⇩1 + length(compE⇩2 e⇩2)"
have IH⇩2: "PROP ?P e⇩2 h⇩1 ls⇩1 (Val v⇩2) h⇩2 ls⇩2 C M ?pc⇩1 v⇩2 xa (v⇩1#vs) frs
(I - pcs(compxE⇩2 e⇩1 pc (size vs)))" by fact
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(v⇩1#vs,ls⇩1,C,M,?pc⇩1)#frs)" using BinOp⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩2,(v⇩2#v⇩1#vs,ls⇩2,C,M,?pc⇩2)#frs)"
using BinOp⇩1.prems IH⇩2 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩2,(w#vs,ls⇩2,C,M,?pc⇩2+1)#frs)"
using BinOp⇩1 by(cases bop) auto
finally show ?case by (auto split: bop.splits simp:add.assoc)
next
case BinOpThrow⇩1⇩1 thus ?case by(fastforce)
next
case (BinOpThrow⇩2⇩1 e⇩1 h⇩0 ls⇩0 v⇩1 h⇩1 ls⇩1 e⇩2 e h⇩2 ls⇩2 bop)
let ?pc = "pc + length(compE⇩2 e⇩1)"
let ?σ⇩1 = "(None,h⇩1,(v⇩1#vs,ls⇩1,C,M,?pc)#frs)"
have 1: "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→ ?σ⇩1"
using BinOpThrow⇩2⇩1 by fastforce
show ?case (is "?N ∧ (?eq ⟶ (∃pc⇩2. ?H pc⇩2))")
proof
show ?N by simp
next
{ assume ?eq
moreover
have "PROP ?P e⇩2 h⇩1 ls⇩1 (throw e) h⇩2 ls⇩2 C M ?pc v xa (v⇩1#vs) frs
(I - pcs(compxE⇩2 e⇩1 pc (size vs)))" by fact
ultimately obtain pc⇩2 where
pc⇩2: "?pc ≤ pc⇩2 ∧ pc⇩2 < ?pc + size(compE⇩2 e⇩2) ∧
¬ caught P pc⇩2 h⇩2 xa (compxE⇩2 e⇩2 ?pc (size vs + 1))" and
2: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 (v⇩1#vs) ls⇩2 pc⇩2 frs"
using BinOpThrow⇩2⇩1.prems by fastforce
have 3: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 vs ls⇩2 pc⇩2 frs"
using 2 BinOpThrow⇩2⇩1.prems pc⇩2 by(auto simp:handle_Cons)
have "?H pc⇩2" using pc⇩2 jvm_trans[OF 1 3] by auto
hence "∃pc⇩2. ?H pc⇩2" by iprover
}
thus "?eq ⟶ (∃pc⇩2. ?H pc⇩2)" by iprover
qed
next
case (FAcc⇩1 e h⇩0 ls⇩0 a h⇩1 ls⇩1 C fs F D w)
let ?pc = "pc + length(compE⇩2 e)"
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(Addr a#vs,ls⇩1,C,M,?pc)#frs)" using FAcc⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩1,(w#vs,ls⇩1,C,M,?pc+1)#frs)"
using FAcc⇩1 by auto
finally show ?case by auto
next
case (FAccNull⇩1 e h⇩0 ls⇩0 h⇩1 ls⇩1 F D)
let ?pc = "pc + length(compE⇩2 e)"
let ?xa = "addr_of_sys_xcpt NullPointer"
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(Null#vs,ls⇩1,C,M,?pc)#frs)" using FAccNull⇩1 by fastforce
also have "P ⊢ … -jvm→ handle P C M ?xa h⇩1 (Null#vs) ls⇩1 ?pc frs"
using FAccNull⇩1.prems
by(fastforce simp:split_beta handle_def simp del: split_paired_Ex)
also have "handle P C M ?xa h⇩1 (Null#vs) ls⇩1 ?pc frs =
handle P C M ?xa h⇩1 vs ls⇩1 ?pc frs"
using FAccNull⇩1.prems by(auto simp add:handle_Cons)
finally show ?case by (auto intro: exI[where x = ?pc])
next
case FAccThrow⇩1 thus ?case by fastforce
next
case (LAss⇩1 e h⇩0 ls⇩0 w h⇩1 ls⇩1 i ls⇩2)
let ?pc = "pc + length(compE⇩2 e)"
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(w#vs,ls⇩1,C,M,?pc)#frs)" using LAss⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩1,(Unit#vs,ls⇩2,C,M,?pc+2)#frs)"
using LAss⇩1 by auto
finally show ?case using LAss⇩1 by auto
next
case LAssThrow⇩1 thus ?case by fastforce
next
case (FAss⇩1 e⇩1 h⇩0 ls⇩0 a h⇩1 ls⇩1 e⇩2 w h⇩2 ls⇩2 C fs fs' F D h⇩2')
let ?pc⇩1 = "pc + length(compE⇩2 e⇩1)"
let ?pc⇩2 = "?pc⇩1 + length(compE⇩2 e⇩2)"
have IH⇩2: "PROP ?P e⇩2 h⇩1 ls⇩1 (Val w) h⇩2 ls⇩2 C M ?pc⇩1 w xa (Addr a#vs) frs
(I - pcs(compxE⇩2 e⇩1 pc (size vs)))" by fact
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(Addr a#vs,ls⇩1,C,M,?pc⇩1)#frs)" using FAss⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩2,(w#Addr a#vs,ls⇩2,C,M,?pc⇩2)#frs)"
using FAss⇩1.prems IH⇩2 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩2',(Unit#vs,ls⇩2,C,M,?pc⇩2+2)#frs)"
using FAss⇩1 by auto
finally show ?case using FAss⇩1 by (auto simp:add.assoc)
next
case (FAssNull⇩1 e⇩1 h⇩0 ls⇩0 h⇩1 ls⇩1 e⇩2 w h⇩2 ls⇩2 F D)
let ?pc⇩1 = "pc + length(compE⇩2 e⇩1)"
let ?pc⇩2 = "?pc⇩1 + length(compE⇩2 e⇩2)"
let ?xa = "addr_of_sys_xcpt NullPointer"
have IH⇩2: "PROP ?P e⇩2 h⇩1 ls⇩1 (Val w) h⇩2 ls⇩2 C M ?pc⇩1 w xa (Null#vs) frs
(I - pcs(compxE⇩2 e⇩1 pc (size vs)))" by fact
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(Null#vs,ls⇩1,C,M,?pc⇩1)#frs)" using FAssNull⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩2,(w#Null#vs,ls⇩2,C,M,?pc⇩2)#frs)"
using FAssNull⇩1.prems IH⇩2 by fastforce
also have "P ⊢ … -jvm→ handle P C M ?xa h⇩2 (w#Null#vs) ls⇩2 ?pc⇩2 frs"
using FAssNull⇩1.prems
by(fastforce simp:split_beta handle_def simp del: split_paired_Ex)
also have "handle P C M ?xa h⇩2 (w#Null#vs) ls⇩2 ?pc⇩2 frs =
handle P C M ?xa h⇩2 vs ls⇩2 ?pc⇩2 frs"
using FAssNull⇩1.prems by(auto simp add:handle_Cons)
finally show ?case by (auto intro: exI[where x = ?pc⇩2])
next
case (FAssThrow⇩2⇩1 e⇩1 h⇩0 ls⇩0 w h⇩1 ls⇩1 e⇩2 e' h⇩2 ls⇩2 F D)
let ?pc⇩1 = "pc + length(compE⇩2 e⇩1)"
let ?σ⇩1 = "(None,h⇩1,(w#vs,ls⇩1,C,M,?pc⇩1)#frs)"
have 1: "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→ ?σ⇩1"
using FAssThrow⇩2⇩1 by fastforce
show ?case (is "?N ∧ (?eq ⟶ (∃pc⇩2. ?H pc⇩2))")
proof
show ?N by simp
next
{ assume ?eq
moreover
have "PROP ?P e⇩2 h⇩1 ls⇩1 (throw e') h⇩2 ls⇩2 C M ?pc⇩1 v xa (w#vs) frs
(I - pcs (compxE⇩2 e⇩1 pc (length vs)))" by fact
ultimately obtain pc⇩2 where
pc⇩2: "?pc⇩1 ≤ pc⇩2 ∧ pc⇩2 < ?pc⇩1 + size(compE⇩2 e⇩2) ∧
¬ caught P pc⇩2 h⇩2 xa (compxE⇩2 e⇩2 ?pc⇩1 (size vs + 1))" and
2: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 (w#vs) ls⇩2 pc⇩2 frs"
using FAssThrow⇩2⇩1.prems by fastforce
have 3: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 vs ls⇩2 pc⇩2 frs"
using 2 FAssThrow⇩2⇩1.prems pc⇩2 by(auto simp:handle_Cons)
have "?H pc⇩2" using pc⇩2 jvm_trans[OF 1 3] by auto
hence "∃pc⇩2. ?H pc⇩2" by iprover
}
thus "?eq ⟶ (∃pc⇩2. ?H pc⇩2)" by iprover
qed
next
case FAssThrow⇩1⇩1 thus ?case by fastforce
next
case (Call⇩1 e h⇩0 ls⇩0 a h⇩1 ls⇩1 es pvs h⇩2 ls⇩2 Ca fs M' Ts T body D ls⇩2' f h⇩3 ls⇩3)
have "P⇩1 ⊢⇩1 ⟨es,(h⇩1, ls⇩1)⟩ [⇒] ⟨map Val pvs,(h⇩2, ls⇩2)⟩" by fact
hence [simp]: "length es = length pvs" by(auto dest:evals⇩1_preserves_elen)
let ?σ⇩0 = "(None,h⇩0,(vs, ls⇩0, C,M,pc)#frs)"
let ?pc⇩1 = "pc + length(compE⇩2 e)"
let ?σ⇩1 = "(None,h⇩1,(Addr a # vs, ls⇩1, C,M,?pc⇩1)#frs)"
let ?pc⇩2 = "?pc⇩1 + length(compEs⇩2 es)"
let ?frs⇩2 = "(rev pvs @ Addr a # vs, ls⇩2, C,M,?pc⇩2)#frs"
let ?σ⇩2 = "(None,h⇩2,?frs⇩2)"
let ?frs⇩2' = "([], ls⇩2', D,M',0) # ?frs⇩2"
let ?σ⇩2' = "(None, h⇩2, ?frs⇩2')"
have IH_es: "PROP ?Ps es h⇩1 ls⇩1 (map Val pvs) h⇩2 ls⇩2 C M ?pc⇩1 pvs xa
(map Val pvs) (Addr a # vs) frs (I - pcs(compxE⇩2 e pc (size vs)))" by fact
have "P ⊢ ?σ⇩0 -jvm→ ?σ⇩1" using Call⇩1 by fastforce
also have "P ⊢ … -jvm→ ?σ⇩2" using IH_es Call⇩1.prems by fastforce
also have "P ⊢ … -jvm→ ?σ⇩2'"
using Call⇩1 by(auto simp add: nth_append compMb⇩2_def)
finally have 1: "P ⊢ ?σ⇩0 -jvm→ ?σ⇩2'".
have "P⇩1 ⊢ Ca sees M': Ts→T = body in D" by fact
then have M'_in_D: "P⇩1 ⊢ D sees M': Ts→T = body in D"
by(rule sees_method_idemp)
hence M'_code: "compP⇩2 P⇩1,D,M',0 ⊳ compE⇩2 body @ [Return]"
and M'_xtab: "compP⇩2 P⇩1,D,M' ⊳ compxE⇩2 body 0 0/{..<size(compE⇩2 body)},0"
by(rule beforeM, rule beforexM)
have IH_body: "PROP ?P body h⇩2 ls⇩2' f h⇩3 ls⇩3 D M' 0 v xa [] ?frs⇩2 ({..<size(compE⇩2 body)})" by fact
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm (is "?val ⟶ ?trans")
proof
assume val: ?val
note 1
also have "P ⊢ ?σ⇩2' -jvm→
(None,h⇩3,([v],ls⇩3,D,M',size(compE⇩2 body))#?frs⇩2)"
using val IH_body Call⇩1.prems M'_code M'_xtab
by (fastforce simp del:split_paired_Ex)
also have "P ⊢ … -jvm→ (None, h⇩3, (v # vs, ls⇩2, C,M,?pc⇩2+1)#frs)"
using Call⇩1 M'_code M'_in_D by(auto simp: nth_append compMb⇩2_def)
finally show ?trans by(simp add:add.assoc)
qed
next
show ?Err (is "?throw ⟶ (∃pc⇩2. ?H pc⇩2)")
proof
assume throw: ?throw
with IH_body obtain pc⇩2 where
pc⇩2: "0 ≤ pc⇩2 ∧ pc⇩2 < size(compE⇩2 body) ∧
¬ caught P pc⇩2 h⇩3 xa (compxE⇩2 body 0 0)" and
2: "P ⊢ ?σ⇩2' -jvm→ handle P D M' xa h⇩3 [] ls⇩3 pc⇩2 ?frs⇩2"
using Call⇩1.prems M'_code M'_xtab
by (fastforce simp del:split_paired_Ex)
have "handle P D M' xa h⇩3 [] ls⇩3 pc⇩2 ?frs⇩2 =
handle P C M xa h⇩3 (rev pvs @ Addr a # vs) ls⇩2 ?pc⇩2 frs"
using pc⇩2 M'_in_D by(auto simp add:handle_def)
also have "… = handle P C M xa h⇩3 vs ls⇩2 ?pc⇩2 frs"
using Call⇩1.prems by(auto simp add:handle_append handle_Cons)
finally have "?H ?pc⇩2" using pc⇩2 jvm_trans[OF 1 2] by auto
thus "∃pc⇩2. ?H pc⇩2" by iprover
qed
qed
next
case (CallParamsThrow⇩1 e h⇩0 ls⇩0 w h⇩1 ls⇩1 es es' h⇩2 ls⇩2 pvs ex es'' M')
let ?σ⇩0 = "(None,h⇩0,(vs, ls⇩0, C,M,pc)#frs)"
let ?pc⇩1 = "pc + length(compE⇩2 e)"
let ?σ⇩1 = "(None,h⇩1,(w # vs, ls⇩1, C,M,?pc⇩1)#frs)"
let ?pc⇩2 = "?pc⇩1 + length(compEs⇩2 es)"
have 1: "P ⊢ ?σ⇩0 -jvm→ ?σ⇩1" using CallParamsThrow⇩1 by fastforce
show ?case (is "?N ∧ (?eq ⟶ (∃pc⇩2. ?H pc⇩2))")
proof
show ?N by simp
next
{ assume ?eq
moreover
have "PROP ?Ps es h⇩1 ls⇩1 es' h⇩2 ls⇩2 C M ?pc⇩1 pvs xa es'' (w#vs) frs
(I - pcs (compxE⇩2 e pc (length vs)))" by fact
ultimately have "∃pc⇩2.
(?pc⇩1 ≤ pc⇩2 ∧ pc⇩2 < ?pc⇩1 + size(compEs⇩2 es) ∧
¬ caught P pc⇩2 h⇩2 xa (compxEs⇩2 es ?pc⇩1 (size vs + 1))) ∧
P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 (w#vs) ls⇩2 pc⇩2 frs"
(is "∃pc⇩2. ?PC pc⇩2 ∧ ?Exec pc⇩2")
using CallParamsThrow⇩1 by force
then obtain pc⇩2 where pc⇩2: "?PC pc⇩2" and 2: "?Exec pc⇩2" by iprover
have "?H pc⇩2" using pc⇩2 jvm_trans[OF 1 2] CallParamsThrow⇩1
by(auto simp:handle_Cons)
hence "∃pc⇩2. ?H pc⇩2" by iprover
}
thus "?eq ⟶ (∃pc⇩2. ?H pc⇩2)" by iprover
qed
next
case (CallNull⇩1 e h⇩0 ls⇩0 h⇩1 ls⇩1 es pvs h⇩2 ls⇩2 M')
have "P⇩1 ⊢⇩1 ⟨es,(h⇩1, ls⇩1)⟩ [⇒] ⟨map Val pvs,(h⇩2, ls⇩2)⟩" by fact
hence [simp]: "length es = length pvs" by(auto dest:evals⇩1_preserves_elen)
let ?pc⇩1 = "pc + length(compE⇩2 e)"
let ?pc⇩2 = "?pc⇩1 + length(compEs⇩2 es)"
let ?xa = "addr_of_sys_xcpt NullPointer"
have IH_es: "PROP ?Ps es h⇩1 ls⇩1 (map Val pvs) h⇩2 ls⇩2 C M ?pc⇩1 pvs xa
(map Val pvs) (Null#vs) frs (I - pcs(compxE⇩2 e pc (size vs)))" by fact
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(Null#vs,ls⇩1,C,M,?pc⇩1)#frs)" using CallNull⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩2,(rev pvs@Null#vs,ls⇩2,C,M,?pc⇩2)#frs)"
using CallNull⇩1 IH_es by fastforce
also have "P ⊢ … -jvm→ handle P C M ?xa h⇩2 (rev pvs@Null#vs) ls⇩2 ?pc⇩2 frs"
using CallNull⇩1.prems
by(auto simp:split_beta handle_def nth_append simp del: split_paired_Ex)
also have "handle P C M ?xa h⇩2 (rev pvs@Null#vs) ls⇩2 ?pc⇩2 frs =
handle P C M ?xa h⇩2 vs ls⇩2 ?pc⇩2 frs"
using CallNull⇩1.prems by(auto simp:handle_Cons handle_append)
finally show ?case by (auto intro: exI[where x = ?pc⇩2])
next
case CallObjThrow⇩1 thus ?case by fastforce
next
case Block⇩1 thus ?case by auto
next
case (Seq⇩1 e⇩1 h⇩0 ls⇩0 w h⇩1 ls⇩1 e⇩2 e⇩2' h⇩2 ls⇩2)
let ?pc⇩1 = "pc + length(compE⇩2 e⇩1)"
let ?σ⇩0 = "(None,h⇩0,(vs,ls⇩0,C,M,pc)#frs)"
let ?σ⇩1 = "(None,h⇩1,(vs,ls⇩1,C,M,?pc⇩1+1)#frs)"
have "P ⊢ ?σ⇩0 -jvm→ (None,h⇩1,(w#vs,ls⇩1,C,M,?pc⇩1)#frs)"
using Seq⇩1 by fastforce
also have "P ⊢ … -jvm→ ?σ⇩1" using Seq⇩1 by auto
finally have eval⇩1: "P ⊢ ?σ⇩0 -jvm→ ?σ⇩1".
let ?pc⇩2 = "?pc⇩1 + 1 + length(compE⇩2 e⇩2)"
have IH⇩2: "PROP ?P e⇩2 h⇩1 ls⇩1 e⇩2' h⇩2 ls⇩2 C M (?pc⇩1+1) v xa vs frs
(I - pcs(compxE⇩2 e⇩1 pc (size vs)))" by fact
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm (is "?val ⟶ ?trans")
proof
assume val: ?val
note eval⇩1
also have "P ⊢ ?σ⇩1 -jvm→ (None,h⇩2,(v#vs,ls⇩2,C,M,?pc⇩2)#frs)"
using val Seq⇩1.prems IH⇩2 by fastforce
finally show ?trans by(simp add:add.assoc)
qed
next
show ?Err (is "?throw ⟶ (∃pc⇩2. ?H pc⇩2)")
proof
assume throw: ?throw
then obtain pc⇩2 where
pc⇩2: "?pc⇩1+1 ≤ pc⇩2 ∧ pc⇩2 < ?pc⇩2 ∧
¬ caught P pc⇩2 h⇩2 xa (compxE⇩2 e⇩2 (?pc⇩1+1) (size vs))" and
eval⇩2: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 vs ls⇩2 pc⇩2 frs"
using IH⇩2 Seq⇩1.prems by fastforce
have "?H pc⇩2" using pc⇩2 jvm_trans[OF eval⇩1 eval⇩2] by auto
thus "∃pc⇩2. ?H pc⇩2" by iprover
qed
qed
next
case SeqThrow⇩1 thus ?case by fastforce
next
case (CondT⇩1 e h⇩0 ls⇩0 h⇩1 ls⇩1 e⇩1 e' h⇩2 ls⇩2 e⇩2)
let ?pc⇩1 = "pc + length(compE⇩2 e)"
let ?σ⇩0 = "(None,h⇩0,(vs,ls⇩0,C,M,pc)#frs)"
let ?σ⇩1 = "(None,h⇩1,(vs,ls⇩1,C,M,?pc⇩1+1)#frs)"
have "P ⊢ ?σ⇩0 -jvm→ (None,h⇩1,(Bool(True)#vs,ls⇩1,C,M,?pc⇩1)#frs)"
using CondT⇩1 by (fastforce simp add: Int_Un_distrib)
also have "P ⊢ … -jvm→ ?σ⇩1" using CondT⇩1 by auto
finally have eval⇩1: "P ⊢ ?σ⇩0 -jvm→ ?σ⇩1".
let ?pc⇩1' = "?pc⇩1 + 1 + length(compE⇩2 e⇩1)"
let ?pc⇩2' = "?pc⇩1' + 1 + length(compE⇩2 e⇩2)"
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm (is "?val ⟶ ?trans")
proof
assume val: ?val
note eval⇩1
also have "P ⊢ ?σ⇩1 -jvm→ (None,h⇩2,(v#vs,ls⇩2,C,M,?pc⇩1')#frs)"
using val CondT⇩1 by(fastforce simp:Int_Un_distrib)
also have "P ⊢ … -jvm→ (None,h⇩2,(v#vs,ls⇩2,C,M,?pc⇩2')#frs)"
using CondT⇩1 by(auto simp:add.assoc)
finally show ?trans by(simp add:add.assoc)
qed
next
show ?Err (is "?throw ⟶ (∃pc⇩2. ?H pc⇩2)")
proof
let ?d = "size vs"
let ?I = "I - pcs(compxE⇩2 e pc ?d) - pcs(compxE⇩2 e⇩2 (?pc⇩1'+1) ?d)"
assume throw: ?throw
moreover
have "PROP ?P e⇩1 h⇩1 ls⇩1 e' h⇩2 ls⇩2 C M (?pc⇩1+1) v xa vs frs ?I" by fact
ultimately obtain pc⇩2 where
pc⇩2: "?pc⇩1+1 ≤ pc⇩2 ∧ pc⇩2 < ?pc⇩1' ∧
¬ caught P pc⇩2 h⇩2 xa (compxE⇩2 e⇩1 (?pc⇩1+1) (size vs))" and
eval⇩2: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 vs ls⇩2 pc⇩2 frs"
using CondT⇩1.prems by (fastforce simp:Int_Un_distrib)
have "?H pc⇩2" using pc⇩2 jvm_trans[OF eval⇩1 eval⇩2] by auto
thus "∃pc⇩2. ?H pc⇩2" by iprover
qed
qed
next
case (CondF⇩1 e h⇩0 ls⇩0 h⇩1 ls⇩1 e⇩2 e' h⇩2 ls⇩2 e⇩1)
let ?pc⇩1 = "pc + length(compE⇩2 e)"
let ?pc⇩2 = "?pc⇩1 + 1 + length(compE⇩2 e⇩1)+ 1"
let ?pc⇩2' = "?pc⇩2 + length(compE⇩2 e⇩2)"
let ?σ⇩0 = "(None,h⇩0,(vs,ls⇩0,C,M,pc)#frs)"
let ?σ⇩1 = "(None,h⇩1,(vs,ls⇩1,C,M,?pc⇩2)#frs)"
have "P ⊢ ?σ⇩0 -jvm→ (None,h⇩1,(Bool(False)#vs,ls⇩1,C,M,?pc⇩1)#frs)"
using CondF⇩1 by (fastforce simp add: Int_Un_distrib)
also have "P ⊢ … -jvm→ ?σ⇩1" using CondF⇩1 by auto
finally have eval⇩1: "P ⊢ ?σ⇩0 -jvm→ ?σ⇩1".
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm (is "?val ⟶ ?trans")
proof
assume val: ?val
note eval⇩1
also have "P ⊢ ?σ⇩1 -jvm→ (None,h⇩2,(v#vs,ls⇩2,C,M,?pc⇩2')#frs)"
using val CondF⇩1 by(fastforce simp:Int_Un_distrib)
finally show ?trans by(simp add:add.assoc)
qed
next
show ?Err (is "?throw ⟶ (∃pc⇩2. ?H pc⇩2)")
proof
let ?d = "size vs"
let ?I = "I - pcs(compxE⇩2 e pc ?d) - pcs(compxE⇩2 e⇩1 (?pc⇩1+1) ?d)"
assume throw: ?throw
moreover
have "PROP ?P e⇩2 h⇩1 ls⇩1 e' h⇩2 ls⇩2 C M ?pc⇩2 v xa vs frs ?I" by fact
ultimately obtain pc⇩2 where
pc⇩2: "?pc⇩2 ≤ pc⇩2 ∧ pc⇩2 < ?pc⇩2' ∧
¬ caught P pc⇩2 h⇩2 xa (compxE⇩2 e⇩2 ?pc⇩2 ?d)" and
eval⇩2: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 vs ls⇩2 pc⇩2 frs"
using CondF⇩1.prems by(fastforce simp:Int_Un_distrib)
have "?H pc⇩2" using pc⇩2 jvm_trans[OF eval⇩1 eval⇩2] by auto
thus "∃pc⇩2. ?H pc⇩2" by iprover
qed
qed
next
case (CondThrow⇩1 e h⇩0 ls⇩0 f h⇩1 ls⇩1 e⇩1 e⇩2)
let ?d = "size vs"
let ?xt⇩1 = "compxE⇩2 e⇩1 (pc+size(compE⇩2 e)+1) ?d"
let ?xt⇩2 = "compxE⇩2 e⇩2 (pc+size(compE⇩2 e)+size(compE⇩2 e⇩1)+2) ?d"
let ?I = "I - (pcs ?xt⇩1 ∪ pcs ?xt⇩2)"
have "pcs(compxE⇩2 e pc ?d) ∩ pcs(?xt⇩1 @ ?xt⇩2) = {}"
using CondThrow⇩1.prems by (simp add:Int_Un_distrib)
moreover have "PROP ?P e h⇩0 ls⇩0 (throw f) h⇩1 ls⇩1 C M pc v xa vs frs ?I" by fact
ultimately show ?case using CondThrow⇩1.prems by fastforce
next
case (WhileF⇩1 e h⇩0 ls⇩0 h⇩1 ls⇩1 c)
let ?pc = "pc + length(compE⇩2 e)"
let ?pc' = "?pc + length(compE⇩2 c) + 3"
have "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(Bool False#vs,ls⇩1,C,M,?pc)#frs)"
using WhileF⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩1,(vs,ls⇩1,C,M,?pc')#frs)"
using WhileF⇩1 by (auto simp:add.assoc)
also have "P ⊢ … -jvm→ (None,h⇩1,(Unit#vs,ls⇩1,C,M,?pc'+1)#frs)"
using WhileF⇩1.prems by (auto simp:eval_nat_numeral)
finally show ?case by (simp add:add.assoc eval_nat_numeral)
next
case (WhileT⇩1 e h⇩0 ls⇩0 h⇩1 ls⇩1 c v⇩1 h⇩2 ls⇩2 e⇩3 h⇩3 ls⇩3)
let ?pc = "pc + length(compE⇩2 e)"
let ?pc' = "?pc + length(compE⇩2 c) + 1"
let ?σ⇩0 = "(None,h⇩0,(vs,ls⇩0,C,M,pc)#frs)"
let ?σ⇩2 = "(None,h⇩2,(vs,ls⇩2,C,M,pc)#frs)"
have "P ⊢ ?σ⇩0 -jvm→ (None,h⇩1,(Bool True#vs,ls⇩1,C,M,?pc)#frs)"
using WhileT⇩1 by fastforce
also have "P ⊢ … -jvm→ (None,h⇩1,(vs,ls⇩1,C,M,?pc+1)#frs)"
using WhileT⇩1.prems by auto
also have "P ⊢ … -jvm→ (None,h⇩2,(v⇩1#vs,ls⇩2,C,M,?pc')#frs)"
using WhileT⇩1 by(fastforce)
also have "P ⊢ … -jvm→ ?σ⇩2" using WhileT⇩1.prems by auto
finally have 1: "P ⊢ ?σ⇩0 -jvm→ ?σ⇩2".
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm (is "?val ⟶ ?trans")
proof
assume val: ?val
note 1
also have "P ⊢ ?σ⇩2 -jvm→ (None,h⇩3,(v#vs,ls⇩3,C,M,?pc'+3)#frs)"
using val WhileT⇩1 by (auto simp add:add.assoc eval_nat_numeral)
finally show ?trans by(simp add:add.assoc eval_nat_numeral)
qed
next
show ?Err (is "?throw ⟶ (∃pc⇩2. ?H pc⇩2)")
proof
assume throw: ?throw
moreover
have "PROP ?P (while (e) c) h⇩2 ls⇩2 e⇩3 h⇩3 ls⇩3 C M pc v xa vs frs I" by fact
ultimately obtain pc⇩2 where
pc⇩2: "pc ≤ pc⇩2 ∧ pc⇩2 < ?pc'+3 ∧
¬ caught P pc⇩2 h⇩3 xa (compxE⇩2 (while (e) c) pc (size vs))" and
2: "P ⊢ ?σ⇩2 -jvm→ handle P C M xa h⇩3 vs ls⇩3 pc⇩2 frs"
using WhileT⇩1.prems by (auto simp:add.assoc eval_nat_numeral)
have "?H pc⇩2" using pc⇩2 jvm_trans[OF 1 2] by auto
thus "∃pc⇩2. ?H pc⇩2" by iprover
qed
qed
next
case WhileCondThrow⇩1 thus ?case by fastforce
next
case (WhileBodyThrow⇩1 e h⇩0 ls⇩0 h⇩1 ls⇩1 c e' h⇩2 ls⇩2)
let ?pc⇩1 = "pc + length(compE⇩2 e)"
let ?σ⇩0 = "(None,h⇩0,(vs,ls⇩0,C,M,pc)#frs)"
let ?σ⇩1 = "(None,h⇩1,(vs,ls⇩1,C,M,?pc⇩1+1)#frs)"
have "P ⊢ ?σ⇩0 -jvm→ (None,h⇩1,(Bool(True)#vs,ls⇩1,C,M,?pc⇩1)#frs)"
using WhileBodyThrow⇩1 by (fastforce simp add: Int_Un_distrib)
also have "P ⊢ … -jvm→ ?σ⇩1" using WhileBodyThrow⇩1 by auto
finally have eval⇩1: "P ⊢ ?σ⇩0 -jvm→ ?σ⇩1".
let ?pc⇩1' = "?pc⇩1 + 1 + length(compE⇩2 c)"
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm by simp
next
show ?Err (is "?throw ⟶ (∃pc⇩2. ?H pc⇩2)")
proof
assume throw: ?throw
moreover
have "PROP ?P c h⇩1 ls⇩1 (throw e') h⇩2 ls⇩2 C M (?pc⇩1+1) v xa vs frs
(I - pcs (compxE⇩2 e pc (size vs)))" by fact
ultimately obtain pc⇩2 where
pc⇩2: "?pc⇩1+1 ≤ pc⇩2 ∧ pc⇩2 < ?pc⇩1' ∧
¬ caught P pc⇩2 h⇩2 xa (compxE⇩2 c (?pc⇩1+1) (size vs))" and
eval⇩2: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 vs ls⇩2 pc⇩2 frs"
using WhileBodyThrow⇩1.prems by (fastforce simp:Int_Un_distrib)
have "?H pc⇩2" using pc⇩2 jvm_trans[OF eval⇩1 eval⇩2] by auto
thus "∃pc⇩2. ?H pc⇩2" by iprover
qed
qed
next
case (Throw⇩1 e h⇩0 ls⇩0 a h⇩1 ls⇩1)
let ?pc = "pc + size(compE⇩2 e)"
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm by simp
next
show ?Err (is "?throw ⟶ (∃pc⇩1. ?H pc⇩1)")
proof
assume ?throw
hence "P ⊢ (None, h⇩0, (vs, ls⇩0, C, M, pc) # frs) -jvm→
(None, h⇩1, (Addr xa#vs, ls⇩1, C, M, ?pc) # frs)"
using Throw⇩1 by fastforce
also have "P ⊢ … -jvm→ handle P C M xa h⇩1 (Addr xa#vs) ls⇩1 ?pc frs"
using Throw⇩1.prems by(auto simp add:handle_def)
also have "handle P C M xa h⇩1 (Addr xa#vs) ls⇩1 ?pc frs =
handle P C M xa h⇩1 vs ls⇩1 ?pc frs"
using Throw⇩1.prems by(auto simp add:handle_Cons)
finally have "?H ?pc" by simp
thus "∃pc⇩1. ?H pc⇩1" by iprover
qed
qed
next
case (ThrowNull⇩1 e h⇩0 ls⇩0 h⇩1 ls⇩1)
let ?pc = "pc + size(compE⇩2 e)"
let ?xa = "addr_of_sys_xcpt NullPointer"
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm by simp
next
show ?Err (is "?throw ⟶ (∃pc⇩1. ?H pc⇩1)")
proof
assume throw: ?throw
have "P ⊢ (None, h⇩0, (vs, ls⇩0, C, M, pc) # frs) -jvm→
(None, h⇩1, (Null#vs, ls⇩1, C, M, ?pc) # frs)"
using ThrowNull⇩1 by fastforce
also have "P ⊢ … -jvm→ handle P C M ?xa h⇩1 (Null#vs) ls⇩1 ?pc frs"
using ThrowNull⇩1.prems by(auto simp add:handle_def)
also have "handle P C M ?xa h⇩1 (Null#vs) ls⇩1 ?pc frs =
handle P C M ?xa h⇩1 vs ls⇩1 ?pc frs"
using ThrowNull⇩1.prems by(auto simp add:handle_Cons)
finally have "?H ?pc" using throw by simp
thus "∃pc⇩1. ?H pc⇩1" by iprover
qed
qed
next
case ThrowThrow⇩1 thus ?case by fastforce
next
case (Try⇩1 e⇩1 h⇩0 ls⇩0 v⇩1 h⇩1 ls⇩1 Ci i e⇩2)
let ?pc⇩1 = "pc + length(compE⇩2 e⇩1)"
let ?pc⇩1' = "?pc⇩1 + 2 + length(compE⇩2 e⇩2)"
have "P,C,M ⊳ compxE⇩2 (try e⇩1 catch(Ci i) e⇩2) pc (size vs) / I,size vs" by fact
hence "P,C,M ⊳ compxE⇩2 e⇩1 pc (size vs) /
{pc..<pc + length (compE⇩2 e⇩1)},size vs"
using Try⇩1.prems by (fastforce simp:beforex_def split:if_split_asm)
hence "P ⊢ (None,h⇩0,(vs,ls⇩0,C,M,pc)#frs) -jvm→
(None,h⇩1,(v⇩1#vs,ls⇩1,C,M,?pc⇩1)#frs)" using Try⇩1 by auto
also have "P ⊢ … -jvm→ (None,h⇩1,(v⇩1#vs,ls⇩1,C,M,?pc⇩1')#frs)"
using Try⇩1.prems by auto
finally show ?case by (auto simp:add.assoc)
next
case (TryCatch⇩1 e⇩1 h⇩0 ls⇩0 a h⇩1 ls⇩1 D fs Ci i e⇩2 e⇩2' h⇩2 ls⇩2)
let ?e = "try e⇩1 catch(Ci i) e⇩2"
let ?xt = "compxE⇩2 ?e pc (size vs)"
let ?σ⇩0 = "(None,h⇩0,(vs,ls⇩0,C,M,pc)#frs)"
let ?ls⇩1 = "ls⇩1[i := Addr a]"
let ?pc⇩1 = "pc + length(compE⇩2 e⇩1)"
let ?pc⇩1' = "?pc⇩1 + 2"
let ?σ⇩1 = "(None,h⇩1,(vs,?ls⇩1,C,M, ?pc⇩1') # frs)"
have I: "{pc..<pc + length (compE⇩2 (try e⇩1 catch(Ci i) e⇩2))} ⊆ I"
and beforex: "P,C,M ⊳ ?xt/I,size vs" by fact+
have "P ⊢ ?σ⇩0 -jvm→ (None,h⇩1,((Addr a)#vs,ls⇩1,C,M, ?pc⇩1+1) # frs)"
proof -
have "PROP ?P e⇩1 h⇩0 ls⇩0 (Throw a) h⇩1 ls⇩1 C M pc w a vs frs {pc..<pc + length (compE⇩2 e⇩1)}"
by fact
moreover have "P,C,M ⊳ compxE⇩2 e⇩1 pc (size vs)/{pc..<?pc⇩1},size vs"
using beforex I pcs_subset by(force elim!: beforex_appendD1)
ultimately have
"∃pc⇩1. pc ≤ pc⇩1 ∧ pc⇩1 < ?pc⇩1 ∧
¬ caught P pc⇩1 h⇩1 a (compxE⇩2 e⇩1 pc (size vs)) ∧
P ⊢ ?σ⇩0 -jvm→ handle P C M a h⇩1 vs ls⇩1 pc⇩1 frs"
using TryCatch⇩1.prems by auto
then obtain pc⇩1 where
pc⇩1_in_e⇩1: "pc ≤ pc⇩1" "pc⇩1 < ?pc⇩1" and
pc⇩1_not_caught: "¬ caught P pc⇩1 h⇩1 a (compxE⇩2 e⇩1 pc (size vs))" and
0: "P ⊢ ?σ⇩0 -jvm→ handle P C M a h⇩1 vs ls⇩1 pc⇩1 frs" by iprover
from beforex obtain xt⇩0 xt⇩1
where ex_tab: "ex_table_of P C M = xt⇩0 @ ?xt @ xt⇩1"
and disj: "pcs xt⇩0 ∩ I = {}" by(auto simp:beforex_def)
have hp: "h⇩1 a = Some (D, fs)" "P⇩1 ⊢ D ≼⇧* Ci" by fact+
have "pc⇩1 ∉ pcs xt⇩0" using pc⇩1_in_e⇩1 I disj by auto
with pc⇩1_in_e⇩1 pc⇩1_not_caught hp
show ?thesis using ex_tab 0 by(simp add:handle_def matches_ex_entry_def)
qed
also have "P ⊢ … -jvm→ ?σ⇩1" using TryCatch⇩1 by auto
finally have 1: "P ⊢ ?σ⇩0 -jvm→ ?σ⇩1" .
let ?pc⇩2 = "?pc⇩1' + length(compE⇩2 e⇩2)"
let ?I⇩2 = "{?pc⇩1' ..< ?pc⇩2}"
have "P,C,M ⊳ compxE⇩2 ?e pc (size vs) / I,size vs" by fact
hence beforex⇩2: "P,C,M ⊳ compxE⇩2 e⇩2 ?pc⇩1' (size vs) / ?I⇩2, size vs"
using I pcs_subset[of _ ?pc⇩1'] by(auto elim!:beforex_appendD2)
have IH⇩2: "PROP ?P e⇩2 h⇩1 ?ls⇩1 e⇩2' h⇩2 ls⇩2 C M ?pc⇩1' v xa vs frs ?I⇩2" by fact
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm (is "?val ⟶ ?trans")
proof
assume val: ?val
note 1 also have "P ⊢ ?σ⇩1 -jvm→ (None,h⇩2,(v#vs,ls⇩2,C,M,?pc⇩2)#frs)"
using val beforex⇩2 IH⇩2 TryCatch⇩1.prems by auto
finally show ?trans by(simp add:add.assoc)
qed
next
show ?Err (is "?throw ⟶ (∃pc⇩2. ?H pc⇩2)")
proof
assume throw: ?throw
then obtain pc⇩2 where
pc⇩2: "?pc⇩1+2 ≤ pc⇩2 ∧ pc⇩2 < ?pc⇩2 ∧
¬ caught P pc⇩2 h⇩2 xa (compxE⇩2 e⇩2 ?pc⇩1' (size vs))" and
2: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 vs ls⇩2 pc⇩2 frs"
using IH⇩2 beforex⇩2 TryCatch⇩1.prems by auto
have "?H pc⇩2" using pc⇩2 jvm_trans[OF 1 2]
by (simp add:match_ex_entry) (fastforce)
thus "∃pc⇩2. ?H pc⇩2" by iprover
qed
qed
next
case (TryThrow⇩1 e⇩1 h⇩0 ls⇩0 a h⇩1 ls⇩1 D fs Ci i e⇩2)
let ?σ⇩0 = "(None,h⇩0,(vs,ls⇩0,C,M,pc)#frs)"
let ?pc⇩1 = "pc + length(compE⇩2 e⇩1)"
let ?e = "try e⇩1 catch(Ci i) e⇩2"
let ?xt = "compxE⇩2 ?e pc (size vs)"
have I: "{pc..<pc + length (compE⇩2 (try e⇩1 catch(Ci i) e⇩2))} ⊆ I"
and beforex: "P,C,M ⊳ ?xt/I,size vs" by fact+
have "PROP ?P e⇩1 h⇩0 ls⇩0 (Throw a) h⇩1 ls⇩1 C M pc w a vs frs {pc..<pc + length (compE⇩2 e⇩1)}" by fact
moreover have "P,C,M ⊳ compxE⇩2 e⇩1 pc (size vs)/{pc..<?pc⇩1},size vs"
using beforex I pcs_subset by(force elim!: beforex_appendD1)
ultimately have
"∃pc⇩1. pc ≤ pc⇩1 ∧ pc⇩1 < ?pc⇩1 ∧
¬ caught P pc⇩1 h⇩1 a (compxE⇩2 e⇩1 pc (size vs)) ∧
P ⊢ ?σ⇩0 -jvm→ handle P C M a h⇩1 vs ls⇩1 pc⇩1 frs"
using TryThrow⇩1.prems by auto
then obtain pc⇩1 where
pc⇩1_in_e⇩1: "pc ≤ pc⇩1" "pc⇩1 < ?pc⇩1" and
pc⇩1_not_caught: "¬ caught P pc⇩1 h⇩1 a (compxE⇩2 e⇩1 pc (size vs))" and
0: "P ⊢ ?σ⇩0 -jvm→ handle P C M a h⇩1 vs ls⇩1 pc⇩1 frs" by iprover
show ?case (is "?N ∧ (?eq ⟶ (∃pc⇩2. ?H pc⇩2))")
proof
show ?N by simp
next
{ assume ?eq
with TryThrow⇩1 pc⇩1_in_e⇩1 pc⇩1_not_caught 0
have "?H pc⇩1" by (simp add:match_ex_entry) auto
hence "∃pc⇩2. ?H pc⇩2" by iprover
}
thus "?eq ⟶ (∃pc⇩2. ?H pc⇩2)" by iprover
qed
next
case Nil⇩1 thus ?case by simp
next
case (Cons⇩1 e h⇩0 ls⇩0 v h⇩1 ls⇩1 es fs h⇩2 ls⇩2)
let ?pc⇩1 = "pc + length(compE⇩2 e)"
let ?σ⇩0 = "(None,h⇩0,(vs,ls⇩0,C,M,pc)#frs)"
let ?σ⇩1 = "(None,h⇩1,(v#vs,ls⇩1,C,M,?pc⇩1)#frs)"
have 1: "P ⊢ ?σ⇩0 -jvm→ ?σ⇩1" using Cons⇩1 by fastforce
let ?pc⇩2 = "?pc⇩1 + length(compEs⇩2 es)"
have IHs: "PROP ?Ps es h⇩1 ls⇩1 fs h⇩2 ls⇩2 C M ?pc⇩1 (tl ws) xa es' (v#vs) frs
(I - pcs (compxE⇩2 e pc (length vs)))" by fact
show ?case (is "?Norm ∧ ?Err")
proof
show ?Norm (is "?val ⟶ ?trans")
proof
assume val: ?val
note 1
also have "P ⊢ ?σ⇩1 -jvm→ (None,h⇩2,(rev(ws) @ vs,ls⇩2,C,M,?pc⇩2)#frs)"
using val IHs Cons⇩1.prems by fastforce
finally show ?trans by(simp add:add.assoc)
qed
next
show ?Err (is "?throw ⟶ (∃pc⇩2. ?H pc⇩2)")
proof
assume throw: ?throw
then obtain pc⇩2 where
pc⇩2: "?pc⇩1 ≤ pc⇩2 ∧ pc⇩2 < ?pc⇩2 ∧
¬ caught P pc⇩2 h⇩2 xa (compxEs⇩2 es ?pc⇩1 (size vs + 1))" and
2: "P ⊢ ?σ⇩1 -jvm→ handle P C M xa h⇩2 (v#vs) ls⇩2 pc⇩2 frs"
using IHs Cons⇩1.prems
by(fastforce simp:Cons_eq_append_conv neq_Nil_conv)
have "?H pc⇩2" using Cons⇩1.prems pc⇩2 jvm_trans[OF 1 2]
by (auto simp add: handle_Cons)
thus "∃pc⇩2. ?H pc⇩2" by iprover
qed
qed
next
case ConsThrow⇩1 thus ?case by (fastforce simp:Cons_eq_append_conv)
qed
lemma atLeast0AtMost[simp]: "{0::nat..n} = {..n}"
by auto
lemma atLeast0LessThan[simp]: "{0::nat..<n} = {..<n}"
by auto
fun exception :: "'a exp ⇒ addr option" where
"exception (Throw a) = Some a"
| "exception e = None"
lemma comp⇩2_correct:
assumes "method": "P⇩1 ⊢ C sees M:Ts→T = body in C"
and eval: "P⇩1 ⊢⇩1 ⟨body,(h,ls)⟩ ⇒ ⟨e',(h',ls')⟩"
shows "compP⇩2 P⇩1 ⊢ (None,h,[([],ls,C,M,0)]) -jvm→ (exception e',h',[])"
(is "_ ⊢ ?σ⇩0 -jvm→ ?σ⇩1")
proof -
let ?P = "compP⇩2 P⇩1"
have code: "?P,C,M,0 ⊳ compE⇩2 body" using beforeM[OF "method"] by auto
have xtab: "?P,C,M ⊳ compxE⇩2 body 0 (size[])/{..<size(compE⇩2 body)},size[]"
using beforexM[OF "method"] by auto
{ fix v assume [simp]: "e' = Val v"
have "?P ⊢ ?σ⇩0 -jvm→ (None,h',[([v],ls',C,M,size(compE⇩2 body))])"
using Jcc[OF eval code xtab] by auto
also have "?P ⊢ … -jvm→ ?σ⇩1" using beforeM[OF "method"] by auto
finally have ?thesis .
}
moreover
{ fix a assume [simp]: "e' = Throw a"
obtain pc where pc: "0 ≤ pc ∧ pc < size(compE⇩2 body) ∧
¬ caught ?P pc h' a (compxE⇩2 body 0 0)"
and 1: "?P ⊢ ?σ⇩0 -jvm→ handle ?P C M a h' [] ls' pc []"
using Jcc[OF eval code xtab] by fastforce
from pc have "handle ?P C M a h' [] ls' pc [] = ?σ⇩1" using xtab "method"
by(auto simp:handle_def compMb⇩2_def)
with 1 have ?thesis by simp
}
ultimately show ?thesis using eval⇩1_final[OF eval] by(auto simp:final_def)
qed
end
Theory Compiler
section ‹Combining Stages 1 and 2›
theory Compiler
imports Correctness1 Correctness2
begin
definition J2JVM :: "J_prog ⇒ jvm_prog"
where
"J2JVM ≡ compP⇩2 ∘ compP⇩1"
theorem comp_correct:
assumes wwf: "wwf_J_prog P"
and "method": "P ⊢ C sees M:Ts→T = (pns,body) in C"
and eval: "P ⊢ ⟨body,(h,[this#pns [↦] vs])⟩ ⇒ ⟨e',(h',l')⟩"
and sizes: "size vs = size pns + 1" "size rest = max_vars body"
shows "J2JVM P ⊢ (None,h,[([],vs@rest,C,M,0)]) -jvm→ (exception e',h',[])"
proof -
let ?P⇩1 = "compP⇩1 P"
have fv: "fv body ⊆ set (this#pns)"
using wwf "method" by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
have init: "[this#pns [↦] vs] ⊆⇩m [this#pns [↦] vs@rest]"
using sizes by simp
have "?P⇩1 ⊢ C sees M: Ts→T = (compE⇩1 (this#pns) body) in C"
using sees_method_compP[OF "method", of "λ(pns,e). compE⇩1 (this#pns) e"]
by(simp)
moreover obtain ls' where
"?P⇩1 ⊢⇩1 ⟨compE⇩1 (this#pns) body, (h, vs@rest)⟩ ⇒ ⟨fin⇩1 e', (h',ls')⟩"
using eval⇩1_eval[OF wwf eval fv init] sizes by auto
ultimately show ?thesis using comp⇩2_correct eval_final[OF eval]
by(fastforce simp add:J2JVM_def final_def)
qed
end
Theory TypeComp
section ‹Preservation of Well-Typedness›
theory TypeComp
imports Compiler "../BV/BVSpec"
begin
declare nth_append[simp]
locale TC0 =
fixes P :: "J⇩1_prog" and mxl :: nat
begin
definition "ty E e = (THE T. P,E ⊢⇩1 e :: T)"
definition "ty⇩l E A' = map (λi. if i ∈ A' ∧ i < size E then OK(E!i) else Err) [0..<mxl]"
definition "ty⇩i' ST E A = (case A of None ⇒ None | ⌊A'⌋ ⇒ Some(ST, ty⇩l E A'))"
definition "after E A ST e = ty⇩i' (ty E e # ST) E (A ⊔ 𝒜 e)"
end
lemma (in TC0) ty_def2 [simp]: "P,E ⊢⇩1 e :: T ⟹ ty E e = T"
apply (unfold ty_def)
apply(blast intro: the_equality WT⇩1_unique)
done
lemma (in TC0) [simp]: "ty⇩i' ST E None = None"
by (simp add: ty⇩i'_def)
lemma (in TC0) ty⇩l_app_diff[simp]:
"ty⇩l (E@[T]) (A - {size E}) = ty⇩l E A"
by(auto simp add:ty⇩l_def hyperset_defs)
lemma (in TC0) ty⇩i'_app_diff[simp]:
"ty⇩i' ST (E @ [T]) (A ⊖ size E) = ty⇩i' ST E A"
by(auto simp add:ty⇩i'_def hyperset_defs)
lemma (in TC0) ty⇩l_antimono:
"A ⊆ A' ⟹ P ⊢ ty⇩l E A' [≤⇩⊤] ty⇩l E A"
by(auto simp:ty⇩l_def list_all2_conv_all_nth)
lemma (in TC0) ty⇩i'_antimono:
"A ⊆ A' ⟹ P ⊢ ty⇩i' ST E ⌊A'⌋ ≤' ty⇩i' ST E ⌊A⌋"
by(auto simp:ty⇩i'_def ty⇩l_def list_all2_conv_all_nth)
lemma (in TC0) ty⇩l_env_antimono:
"P ⊢ ty⇩l (E@[T]) A [≤⇩⊤] ty⇩l E A"
by(auto simp:ty⇩l_def list_all2_conv_all_nth)
lemma (in TC0) ty⇩i'_env_antimono:
"P ⊢ ty⇩i' ST (E@[T]) A ≤' ty⇩i' ST E A"
by(auto simp:ty⇩i'_def ty⇩l_def list_all2_conv_all_nth)
lemma (in TC0) ty⇩i'_incr:
"P ⊢ ty⇩i' ST (E @ [T]) ⌊insert (size E) A⌋ ≤' ty⇩i' ST E ⌊A⌋"
by(auto simp:ty⇩i'_def ty⇩l_def list_all2_conv_all_nth)
lemma (in TC0) ty⇩l_incr:
"P ⊢ ty⇩l (E @ [T]) (insert (size E) A) [≤⇩⊤] ty⇩l E A"
by(auto simp: hyperset_defs ty⇩l_def list_all2_conv_all_nth)
lemma (in TC0) ty⇩l_in_types:
"set E ⊆ types P ⟹ ty⇩l E A ∈ list mxl (err (types P))"
by(auto simp add:ty⇩l_def intro!:listI dest!: nth_mem)
locale TC1 = TC0
begin
primrec compT :: "ty list ⇒ nat hyperset ⇒ ty list ⇒ expr⇩1 ⇒ ty⇩i' list" and
compTs :: "ty list ⇒ nat hyperset ⇒ ty list ⇒ expr⇩1 list ⇒ ty⇩i' list" where
"compT E A ST (new C) = []"
| "compT E A ST (Cast C e) =
compT E A ST e @ [after E A ST e]"
| "compT E A ST (Val v) = []"
| "compT E A ST (e⇩1 «bop» e⇩2) =
(let ST⇩1 = ty E e⇩1#ST; A⇩1 = A ⊔ 𝒜 e⇩1 in
compT E A ST e⇩1 @ [after E A ST e⇩1] @
compT E A⇩1 ST⇩1 e⇩2 @ [after E A⇩1 ST⇩1 e⇩2])"
| "compT E A ST (Var i) = []"
| "compT E A ST (i := e) = compT E A ST e @
[after E A ST e, ty⇩i' ST E (A ⊔ 𝒜 e ⊔ ⌊{i}⌋)]"
| "compT E A ST (e∙F{D}) =
compT E A ST e @ [after E A ST e]"
| "compT E A ST (e⇩1∙F{D} := e⇩2) =
(let ST⇩1 = ty E e⇩1#ST; A⇩1 = A ⊔ 𝒜 e⇩1; A⇩2 = A⇩1 ⊔ 𝒜 e⇩2 in
compT E A ST e⇩1 @ [after E A ST e⇩1] @
compT E A⇩1 ST⇩1 e⇩2 @ [after E A⇩1 ST⇩1 e⇩2] @
[ty⇩i' ST E A⇩2])"
| "compT E A ST {i:T; e} = compT (E@[T]) (A⊖i) ST e"
| "compT E A ST (e⇩1;;e⇩2) =
(let A⇩1 = A ⊔ 𝒜 e⇩1 in
compT E A ST e⇩1 @ [after E A ST e⇩1, ty⇩i' ST E A⇩1] @
compT E A⇩1 ST e⇩2)"
| "compT E A ST (if (e) e⇩1 else e⇩2) =
(let A⇩0 = A ⊔ 𝒜 e; τ = ty⇩i' ST E A⇩0 in
compT E A ST e @ [after E A ST e, τ] @
compT E A⇩0 ST e⇩1 @ [after E A⇩0 ST e⇩1, τ] @
compT E A⇩0 ST e⇩2)"
| "compT E A ST (while (e) c) =
(let A⇩0 = A ⊔ 𝒜 e; A⇩1 = A⇩0 ⊔ 𝒜 c; τ = ty⇩i' ST E A⇩0 in
compT E A ST e @ [after E A ST e, τ] @
compT E A⇩0 ST c @ [after E A⇩0 ST c, ty⇩i' ST E A⇩1, ty⇩i' ST E A⇩0])"
| "compT E A ST (throw e) = compT E A ST e @ [after E A ST e]"
| "compT E A ST (e∙M(es)) =
compT E A ST e @ [after E A ST e] @
compTs E (A ⊔ 𝒜 e) (ty E e # ST) es"
| "compT E A ST (try e⇩1 catch(C i) e⇩2) =
compT E A ST e⇩1 @ [after E A ST e⇩1] @
[ty⇩i' (Class C#ST) E A, ty⇩i' ST (E@[Class C]) (A ⊔ ⌊{i}⌋)] @
compT (E@[Class C]) (A ⊔ ⌊{i}⌋) ST e⇩2"
| "compTs E A ST [] = []"
| "compTs E A ST (e#es) = compT E A ST e @ [after E A ST e] @
compTs E (A ⊔ (𝒜 e)) (ty E e # ST) es"
definition compT⇩a :: "ty list ⇒ nat hyperset ⇒ ty list ⇒ expr⇩1 ⇒ ty⇩i' list" where
"compT⇩a E A ST e = compT E A ST e @ [after E A ST e]"
end
lemma compE⇩2_not_Nil[simp]: "compE⇩2 e ≠ []"
by(induct e) auto
lemma (in TC1) compT_sizes[simp]:
shows "⋀E A ST. size(compT E A ST e) = size(compE⇩2 e) - 1"
and "⋀E A ST. size(compTs E A ST es) = size(compEs⇩2 es)"
apply(induct e and es rule: compE⇩2.induct compEs⇩2.induct)
apply(auto split:bop.splits nat_diff_split)
done
lemma (in TC1) [simp]: "⋀ST E. ⌊τ⌋ ∉ set (compT E None ST e)"
and [simp]: "⋀ST E. ⌊τ⌋ ∉ set (compTs E None ST es)"
by(induct e and es rule: compT.induct compTs.induct) (simp_all add:after_def)
lemma (in TC0) pair_eq_ty⇩i'_conv:
"(⌊(ST, LT)⌋ = ty⇩i' ST⇩0 E A) =
(case A of None ⇒ False | Some A ⇒ (ST = ST⇩0 ∧ LT = ty⇩l E A))"
by(simp add:ty⇩i'_def)
lemma (in TC0) pair_conv_ty⇩i':
"⌊(ST, ty⇩l E A)⌋ = ty⇩i' ST E ⌊A⌋"
by(simp add:ty⇩i'_def)
declare (in TC0)
ty⇩i'_antimono [intro!] after_def[simp]
pair_conv_ty⇩i'[simp] pair_eq_ty⇩i'_conv[simp]
lemma (in TC1) compT_LT_prefix:
"⋀E A ST⇩0. ⟦ ⌊(ST,LT)⌋ ∈ set(compT E A ST⇩0 e); ℬ e (size E) ⟧
⟹ P ⊢ ⌊(ST,LT)⌋ ≤' ty⇩i' ST E A"
and
"⋀E A ST⇩0. ⟦ ⌊(ST,LT)⌋ ∈ set(compTs E A ST⇩0 es); ℬs es (size E) ⟧
⟹ P ⊢ ⌊(ST,LT)⌋ ≤' ty⇩i' ST E A"
proof(induct e and es rule: compT.induct compTs.induct)
case FAss thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
case BinOp thus ?case
by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans split:bop.splits)
next
case Seq thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
case While thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
case Cond thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
case Block thus ?case
by(force simp add:hyperset_defs ty⇩i'_def simp del:pair_conv_ty⇩i'
elim!:sup_state_opt_trans)
next
case Call thus ?case by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
case Cons_exp thus ?case
by(fastforce simp:hyperset_defs elim!:sup_state_opt_trans)
next
case TryCatch thus ?case
by(fastforce simp:hyperset_defs intro!: ty⇩i'_incr
elim!:sup_state_opt_trans)
qed (auto simp:hyperset_defs)
declare (in TC0)
ty⇩i'_antimono [rule del] after_def[simp del]
pair_conv_ty⇩i'[simp del] pair_eq_ty⇩i'_conv[simp del]
lemma [iff]: "OK None ∈ states P mxs mxl"
by(simp add: JVM_states_unfold)
lemma (in TC0) after_in_states:
"⟦ wf_prog p P; P,E ⊢⇩1 e :: T; set E ⊆ types P; set ST ⊆ types P;
size ST + max_stack e ≤ mxs ⟧
⟹ OK (after E A ST e) ∈ states P mxs mxl"
apply(subgoal_tac "size ST + 1 ≤ mxs")
apply(simp add: after_def ty⇩i'_def JVM_states_unfold ty⇩l_in_types)
apply(blast intro!:listI WT⇩1_is_type)
using max_stack1[of e] apply simp
done
lemma (in TC0) OK_ty⇩i'_in_statesI[simp]:
"⟦ set E ⊆ types P; set ST ⊆ types P; size ST ≤ mxs ⟧
⟹ OK (ty⇩i' ST E A) ∈ states P mxs mxl"
apply(simp add:ty⇩i'_def JVM_states_unfold ty⇩l_in_types)
apply(blast intro!:listI)
done
lemma is_class_type_aux: "is_class P C ⟹ is_type P (Class C)"
by(simp)
declare is_type_simps[simp del] subsetI[rule del]
theorem (in TC1) compT_states:
assumes wf: "wf_prog p P"
shows "⋀E T A ST.
⟦ P,E ⊢⇩1 e :: T; set E ⊆ types P; set ST ⊆ types P;
size ST + max_stack e ≤ mxs; size E + max_vars e ≤ mxl ⟧
⟹ OK ` set(compT E A ST e) ⊆ states P mxs mxl"
(is "⋀E T A ST. PROP ?P e E T A ST")
and "⋀E Ts A ST.
⟦ P,E ⊢⇩1 es[::]Ts; set E ⊆ types P; set ST ⊆ types P;
size ST + max_stacks es ≤ mxs; size E + max_varss es ≤ mxl ⟧
⟹ OK ` set(compTs E A ST es) ⊆ states P mxs mxl"
(is "⋀E Ts A ST. PROP ?Ps es E Ts A ST")
proof(induct e and es rule: compT.induct compTs.induct)
case new thus ?case by(simp)
next
case (Cast C e) thus ?case by (auto simp:after_in_states[OF wf])
next
case Val thus ?case by(simp)
next
case Var thus ?case by(simp)
next
case LAss thus ?case by(auto simp:after_in_states[OF wf])
next
case FAcc thus ?case by(auto simp:after_in_states[OF wf])
next
case FAss thus ?case
by(auto simp:image_Un WT⇩1_is_type[OF wf] after_in_states[OF wf])
next
case Seq thus ?case
by(auto simp:image_Un after_in_states[OF wf])
next
case BinOp thus ?case
by(auto simp:image_Un WT⇩1_is_type[OF wf] after_in_states[OF wf])
next
case Cond thus ?case
by(force simp:image_Un WT⇩1_is_type[OF wf] after_in_states[OF wf])
next
case While thus ?case
by(auto simp:image_Un WT⇩1_is_type[OF wf] after_in_states[OF wf])
next
case Block thus ?case by(auto)
next
case (TryCatch e⇩1 C i e⇩2)
moreover have "size ST + 1 ≤ mxs" using TryCatch.prems max_stack1[of e⇩1] by auto
ultimately show ?case
by(auto simp:image_Un WT⇩1_is_type[OF wf] after_in_states[OF wf]
is_class_type_aux)
next
case Nil_exp thus ?case by simp
next
case Cons_exp thus ?case
by(auto simp:image_Un WT⇩1_is_type[OF wf] after_in_states[OF wf])
next
case throw thus ?case
by(auto simp: WT⇩1_is_type[OF wf] after_in_states[OF wf])
next
case Call thus ?case
by(auto simp:image_Un WT⇩1_is_type[OF wf] after_in_states[OF wf])
qed
declare is_type_simps[simp] subsetI[intro!]
definition shift :: "nat ⇒ ex_table ⇒ ex_table"
where
"shift n xt ≡ map (λ(from,to,C,handler,depth). (from+n,to+n,C,handler+n,depth)) xt"
lemma [simp]: "shift 0 xt = xt"
by(induct xt)(auto simp:shift_def)
lemma [simp]: "shift n [] = []"
by(simp add:shift_def)
lemma [simp]: "shift n (xt⇩1 @ xt⇩2) = shift n xt⇩1 @ shift n xt⇩2"
by(simp add:shift_def)
lemma [simp]: "shift m (shift n xt) = shift (m+n) xt"
by(induct xt)(auto simp:shift_def)
lemma [simp]: "pcs (shift n xt) = {pc+n|pc. pc ∈ pcs xt}"
apply(auto simp:shift_def pcs_def)
apply(rule_tac x = "x-n" in exI)
apply (force split:nat_diff_split)
done
lemma shift_compxE⇩2:
shows "⋀pc pc' d. shift pc (compxE⇩2 e pc' d) = compxE⇩2 e (pc' + pc) d"
and "⋀pc pc' d. shift pc (compxEs⇩2 es pc' d) = compxEs⇩2 es (pc' + pc) d"
apply(induct e and es rule: compxE⇩2.induct compxEs⇩2.induct)
apply(auto simp:shift_def ac_simps)
done
lemma compxE⇩2_size_convs[simp]:
shows "n ≠ 0 ⟹ compxE⇩2 e n d = shift n (compxE⇩2 e 0 d)"
and "n ≠ 0 ⟹ compxEs⇩2 es n d = shift n (compxEs⇩2 es 0 d)"
by(simp_all add:shift_compxE⇩2)
locale TC2 = TC1 +
fixes T⇩r :: ty and mxs :: pc
begin
definition
wt_instrs :: "instr list ⇒ ex_table ⇒ ty⇩i' list ⇒ bool"
("(⊢ _, _ /[::]/ _)" [0,0,51] 50) where
"⊢ is,xt [::] τs ⟷ size is < size τs ∧ pcs xt ⊆ {0..<size is} ∧
(∀pc< size is. P,T⇩r,mxs,size τs,xt ⊢ is!pc,pc :: τs)"
end
notation TC2.wt_instrs ("(_,_,_ ⊢/ _, _ /[::]/ _)" [50,50,50,50,50,51] 50)
lemmas (in TC2) wt_defs =
wt_instrs_def wt_instr_def app_def eff_def norm_eff_def
lemma (in TC2) [simp]: "τs ≠ [] ⟹ ⊢ [],[] [::] τs"
by (simp add: wt_defs)
lemma [simp]: "eff i P pc et None = []"
by (simp add: Effect.eff_def)
declare split_comp_eq[simp del]
lemma wt_instr_appR:
"⟦ P,T,m,mpc,xt ⊢ is!pc,pc :: τs;
pc < size is; size is < size τs; mpc ≤ size τs; mpc ≤ mpc' ⟧
⟹ P,T,m,mpc',xt ⊢ is!pc,pc :: τs@τs'"
by (fastforce simp:wt_instr_def app_def)
lemma relevant_entries_shift [simp]:
"relevant_entries P i (pc+n) (shift n xt) = shift n (relevant_entries P i pc xt)"
apply (induct xt)
apply (unfold relevant_entries_def shift_def)
apply simp
apply (auto simp add: is_relevant_entry_def)
done
lemma [simp]:
"xcpt_eff i P (pc+n) τ (shift n xt) =
map (λ(pc,τ). (pc + n, τ)) (xcpt_eff i P pc τ xt)"
apply(simp add: xcpt_eff_def)
apply(cases τ)
apply(auto simp add: shift_def)
done
lemma [simp]:
"app⇩i (i, P, pc, m, T, τ) ⟹
eff i P (pc+n) (shift n xt) (Some τ) =
map (λ(pc,τ). (pc+n,τ)) (eff i P pc xt (Some τ))"
apply(simp add:eff_def norm_eff_def)
apply(cases "i",auto)
done
lemma [simp]:
"xcpt_app i P (pc+n) mxs (shift n xt) τ = xcpt_app i P pc mxs xt τ"
by (simp add: xcpt_app_def) (auto simp add: shift_def)
lemma wt_instr_appL:
"⟦ P,T,m,mpc,xt ⊢ i,pc :: τs; pc < size τs; mpc ≤ size τs ⟧
⟹ P,T,m,mpc + size τs',shift (size τs') xt ⊢ i,pc+size τs' :: τs'@τs"
apply(auto simp:wt_instr_def app_def)
prefer 2 apply(fast)
prefer 2 apply(fast)
apply(cases "i",auto)
done
lemma wt_instr_Cons:
"⟦ P,T,m,mpc - 1,[] ⊢ i,pc - 1 :: τs;
0 < pc; 0 < mpc; pc < size τs + 1; mpc ≤ size τs + 1 ⟧
⟹ P,T,m,mpc,[] ⊢ i,pc :: τ#τs"
apply(drule wt_instr_appL[where τs' = "[τ]"])
apply arith
apply arith
apply (simp split:nat_diff_split_asm)
done
lemma wt_instr_append:
"⟦ P,T,m,mpc - size τs',[] ⊢ i,pc - size τs' :: τs;
size τs' ≤ pc; size τs' ≤ mpc; pc < size τs + size τs'; mpc ≤ size τs + size τs' ⟧
⟹ P,T,m,mpc,[] ⊢ i,pc :: τs'@τs"
apply(drule wt_instr_appL[where τs' = τs'])
apply arith
apply arith
apply (simp split:nat_diff_split_asm)
done
lemma xcpt_app_pcs:
"pc ∉ pcs xt ⟹ xcpt_app i P pc mxs xt τ"
by (auto simp add: xcpt_app_def relevant_entries_def is_relevant_entry_def pcs_def)
lemma xcpt_eff_pcs:
"pc ∉ pcs xt ⟹ xcpt_eff i P pc τ xt = []"
by (cases τ)
(auto simp add: is_relevant_entry_def xcpt_eff_def relevant_entries_def pcs_def
intro!: filter_False)
lemma pcs_shift:
"pc < n ⟹ pc ∉ pcs (shift n xt)"
by (auto simp add: shift_def pcs_def)
lemma wt_instr_appRx:
"⟦ P,T,m,mpc,xt ⊢ is!pc,pc :: τs; pc < size is; size is < size τs; mpc ≤ size τs ⟧
⟹ P,T,m,mpc,xt @ shift (size is) xt' ⊢ is!pc,pc :: τs"
by (auto simp:wt_instr_def eff_def app_def xcpt_app_pcs xcpt_eff_pcs)
lemma wt_instr_appLx:
"⟦ P,T,m,mpc,xt ⊢ i,pc :: τs; pc ∉ pcs xt' ⟧
⟹ P,T,m,mpc,xt'@xt ⊢ i,pc :: τs"
by (auto simp:wt_instr_def app_def eff_def xcpt_app_pcs xcpt_eff_pcs)
lemma (in TC2) wt_instrs_extR:
"⊢ is,xt [::] τs ⟹ ⊢ is,xt [::] τs @ τs'"
by(auto simp add:wt_instrs_def wt_instr_appR)
lemma (in TC2) wt_instrs_ext:
"⟦ ⊢ is⇩1,xt⇩1 [::] τs⇩1@τs⇩2; ⊢ is⇩2,xt⇩2 [::] τs⇩2; size τs⇩1 = size is⇩1 ⟧
⟹ ⊢ is⇩1@is⇩2, xt⇩1 @ shift (size is⇩1) xt⇩2 [::] τs⇩1@τs⇩2"
apply(clarsimp simp:wt_instrs_def)
apply(rule conjI, fastforce)
apply(rule conjI, fastforce)
apply clarsimp
apply(rule conjI, fastforce simp:wt_instr_appRx)
apply clarsimp
apply(erule_tac x = "pc - size is⇩1" in allE)+
apply(thin_tac "P ⟶ Q" for P Q)
apply(erule impE, arith)
apply(drule_tac τs' = "τs⇩1" in wt_instr_appL)
apply arith
apply simp
apply(fastforce simp add:add.commute intro!: wt_instr_appLx)
done
corollary (in TC2) wt_instrs_ext2:
"⟦ ⊢ is⇩2,xt⇩2 [::] τs⇩2; ⊢ is⇩1,xt⇩1 [::] τs⇩1@τs⇩2; size τs⇩1 = size is⇩1 ⟧
⟹ ⊢ is⇩1@is⇩2, xt⇩1 @ shift (size is⇩1) xt⇩2 [::] τs⇩1@τs⇩2"
by(rule wt_instrs_ext)
corollary (in TC2) wt_instrs_ext_prefix [trans]:
"⟦ ⊢ is⇩1,xt⇩1 [::] τs⇩1@τs⇩2; ⊢ is⇩2,xt⇩2 [::] τs⇩3;
size τs⇩1 = size is⇩1; prefix τs⇩3 τs⇩2 ⟧
⟹ ⊢ is⇩1@is⇩2, xt⇩1 @ shift (size is⇩1) xt⇩2 [::] τs⇩1@τs⇩2"
by(bestsimp simp:prefix_def elim: wt_instrs_ext dest:wt_instrs_extR)
corollary (in TC2) wt_instrs_app:
assumes is⇩1: "⊢ is⇩1,xt⇩1 [::] τs⇩1@[τ]"
assumes is⇩2: "⊢ is⇩2,xt⇩2 [::] τ#τs⇩2"
assumes s: "size τs⇩1 = size is⇩1"
shows "⊢ is⇩1@is⇩2, xt⇩1@shift (size is⇩1) xt⇩2 [::] τs⇩1@τ#τs⇩2"
proof -
from is⇩1 have "⊢ is⇩1,xt⇩1 [::] (τs⇩1@[τ])@τs⇩2"
by (rule wt_instrs_extR)
hence "⊢ is⇩1,xt⇩1 [::] τs⇩1@τ#τs⇩2" by simp
from this is⇩2 s show ?thesis by (rule wt_instrs_ext)
qed
corollary (in TC2) wt_instrs_app_last[trans]:
"⟦ ⊢ is⇩2,xt⇩2 [::] τ#τs⇩2; ⊢ is⇩1,xt⇩1 [::] τs⇩1;
last τs⇩1 = τ; size τs⇩1 = size is⇩1+1 ⟧
⟹ ⊢ is⇩1@is⇩2, xt⇩1@shift (size is⇩1) xt⇩2 [::] τs⇩1@τs⇩2"
apply(cases τs⇩1 rule:rev_cases)
apply simp
apply(simp add:wt_instrs_app)
done
corollary (in TC2) wt_instrs_append_last[trans]:
"⟦ ⊢ is,xt [::] τs; P,T⇩r,mxs,mpc,[] ⊢ i,pc :: τs;
pc = size is; mpc = size τs; size is + 1 < size τs ⟧
⟹ ⊢ is@[i],xt [::] τs"
apply(clarsimp simp add:wt_instrs_def)
apply(rule conjI, fastforce)
apply(fastforce intro!:wt_instr_appLx[where xt = "[]",simplified]
dest!:less_antisym)
done
corollary (in TC2) wt_instrs_app2:
"⟦ ⊢ is⇩2,xt⇩2 [::] τ'#τs⇩2; ⊢ is⇩1,xt⇩1 [::] τ#τs⇩1@[τ'];
xt' = xt⇩1 @ shift (size is⇩1) xt⇩2; size τs⇩1+1 = size is⇩1 ⟧
⟹ ⊢ is⇩1@is⇩2,xt' [::] τ#τs⇩1@τ'#τs⇩2"
using wt_instrs_app[where ?τs⇩1.0 = "τ # τs⇩1"] by simp
corollary (in TC2) wt_instrs_app2_simp[trans,simp]:
"⟦ ⊢ is⇩2,xt⇩2 [::] τ'#τs⇩2; ⊢ is⇩1,xt⇩1 [::] τ#τs⇩1@[τ']; size τs⇩1+1 = size is⇩1 ⟧
⟹ ⊢ is⇩1@is⇩2, xt⇩1@shift (size is⇩1) xt⇩2 [::] τ#τs⇩1@τ'#τs⇩2"
using wt_instrs_app[where ?τs⇩1.0 = "τ # τs⇩1"] by simp
corollary (in TC2) wt_instrs_Cons[simp]:
"⟦ τs ≠ []; ⊢ [i],[] [::] [τ,τ']; ⊢ is,xt [::] τ'#τs ⟧
⟹ ⊢ i#is,shift 1 xt [::] τ#τ'#τs"
using wt_instrs_app2[where ?is⇩1.0 = "[i]" and ?τs⇩1.0 = "[]" and ?is⇩2.0 = "is"
and ?xt⇩1.0 = "[]"]
by simp
corollary (in TC2) wt_instrs_Cons2[trans]:
assumes τs: "⊢ is,xt [::] τs"
assumes i: "P,T⇩r,mxs,mpc,[] ⊢ i,0 :: τ#τs"
assumes mpc: "mpc = size τs + 1"
shows "⊢ i#is,shift 1 xt [::] τ#τs"
proof -
from τs have "τs ≠ []" by (auto simp: wt_instrs_def)
with mpc i have "⊢ [i],[] [::] [τ]@τs" by (simp add: wt_instrs_def)
with τs show ?thesis by (fastforce dest: wt_instrs_ext)
qed
lemma (in TC2) wt_instrs_last_incr[trans]:
"⟦ ⊢ is,xt [::] τs@[τ]; P ⊢ τ ≤' τ' ⟧ ⟹ ⊢ is,xt [::] τs@[τ']"
apply(clarsimp simp add:wt_instrs_def wt_instr_def)
apply(rule conjI)
apply(fastforce)
apply(clarsimp)
apply(rename_tac pc' tau')
apply(erule allE, erule (1) impE)
apply(clarsimp)
apply(drule (1) bspec)
apply(clarsimp)
apply(subgoal_tac "pc' = size τs")
prefer 2
apply(clarsimp simp:app_def)
apply(drule (1) bspec)
apply(clarsimp)
apply(auto elim!:sup_state_opt_trans)
done
lemma [iff]: "xcpt_app i P pc mxs [] τ"
by (simp add: xcpt_app_def relevant_entries_def)
lemma [simp]: "xcpt_eff i P pc τ [] = []"
by (simp add: xcpt_eff_def relevant_entries_def)
lemma (in TC2) wt_New:
"⟦ is_class P C; size ST < mxs ⟧ ⟹
⊢ [New C],[] [::] [ty⇩i' ST E A, ty⇩i' (Class C#ST) E A]"
by(simp add:wt_defs ty⇩i'_def)
lemma (in TC2) wt_Cast:
"is_class P C ⟹
⊢ [Checkcast C],[] [::] [ty⇩i' (Class D # ST) E A, ty⇩i' (Class C # ST) E A]"
by(simp add: ty⇩i'_def wt_defs)
lemma (in TC2) wt_Push:
"⟦ size ST < mxs; typeof v = Some T ⟧
⟹ ⊢ [Push v],[] [::] [ty⇩i' ST E A, ty⇩i' (T#ST) E A]"
by(simp add: ty⇩i'_def wt_defs)
lemma (in TC2) wt_Pop:
"⊢ [Pop],[] [::] (ty⇩i' (T#ST) E A # ty⇩i' ST E A # τs)"
by(simp add: ty⇩i'_def wt_defs)
lemma (in TC2) wt_CmpEq:
"⟦ P ⊢ T⇩1 ≤ T⇩2 ∨ P ⊢ T⇩2 ≤ T⇩1⟧
⟹ ⊢ [CmpEq],[] [::] [ty⇩i' (T⇩2 # T⇩1 # ST) E A, ty⇩i' (Boolean # ST) E A]"
by(auto simp:ty⇩i'_def wt_defs elim!: refTE not_refTE)
lemma (in TC2) wt_IAdd:
"⊢ [IAdd],[] [::] [ty⇩i' (Integer#Integer#ST) E A, ty⇩i' (Integer#ST) E A]"
by(simp add:ty⇩i'_def wt_defs)
lemma (in TC2) wt_Load:
"⟦ size ST < mxs; size E ≤ mxl; i ∈∈ A; i < size E ⟧
⟹ ⊢ [Load i],[] [::] [ty⇩i' ST E A, ty⇩i' (E!i # ST) E A]"
by(auto simp add:ty⇩i'_def wt_defs ty⇩l_def hyperset_defs)
lemma (in TC2) wt_Store:
"⟦ P ⊢ T ≤ E!i; i < size E; size E ≤ mxl ⟧ ⟹
⊢ [Store i],[] [::] [ty⇩i' (T#ST) E A, ty⇩i' ST E (⌊{i}⌋ ⊔ A)]"
by(auto simp:hyperset_defs nth_list_update ty⇩i'_def wt_defs ty⇩l_def
intro:list_all2_all_nthI)
lemma (in TC2) wt_Get:
"⟦ P ⊢ C sees F:T in D ⟧ ⟹
⊢ [Getfield F D],[] [::] [ty⇩i' (Class C # ST) E A, ty⇩i' (T # ST) E A]"
by(auto simp: ty⇩i'_def wt_defs dest: sees_field_idemp sees_field_decl_above)
lemma (in TC2) wt_Put:
"⟦ P ⊢ C sees F:T in D; P ⊢ T' ≤ T ⟧ ⟹
⊢ [Putfield F D],[] [::] [ty⇩i' (T' # Class C # ST) E A, ty⇩i' ST E A]"
by(auto intro: sees_field_idemp sees_field_decl_above simp: ty⇩i'_def wt_defs)
lemma (in TC2) wt_Throw:
"⊢ [Throw],[] [::] [ty⇩i' (Class C # ST) E A, τ']"
by(auto simp: ty⇩i'_def wt_defs)
lemma (in TC2) wt_IfFalse:
"⟦ 2 ≤ i; nat i < size τs + 2; P ⊢ ty⇩i' ST E A ≤' τs ! nat(i - 2) ⟧
⟹ ⊢ [IfFalse i],[] [::] ty⇩i' (Boolean # ST) E A # ty⇩i' ST E A # τs"
by(simp add: ty⇩i'_def wt_defs eval_nat_numeral nat_diff_distrib)
lemma wt_Goto:
"⟦ 0 ≤ int pc + i; nat (int pc + i) < size τs; size τs ≤ mpc;
P ⊢ τs!pc ≤' τs ! nat (int pc + i) ⟧
⟹ P,T,mxs,mpc,[] ⊢ Goto i,pc :: τs"
by(clarsimp simp add: TC2.wt_defs)
lemma (in TC2) wt_Invoke:
"⟦ size es = size Ts'; P ⊢ C sees M: Ts→T = m in D; P ⊢ Ts' [≤] Ts ⟧
⟹ ⊢ [Invoke M (size es)],[] [::] [ty⇩i' (rev Ts' @ Class C # ST) E A, ty⇩i' (T#ST) E A]"
by(fastforce simp add: ty⇩i'_def wt_defs)
corollary (in TC2) wt_instrs_app3[simp]:
"⟦ ⊢ is⇩2,[] [::] (τ' # τs⇩2); ⊢ is⇩1,xt⇩1 [::] τ # τs⇩1 @ [τ']; size τs⇩1+1 = size is⇩1⟧
⟹ ⊢ (is⇩1 @ is⇩2),xt⇩1 [::] τ # τs⇩1 @ τ' # τs⇩2"
using wt_instrs_app2[where ?xt⇩2.0 = "[]"] by (simp add:shift_def)
corollary (in TC2) wt_instrs_Cons3[simp]:
"⟦ τs ≠ []; ⊢ [i],[] [::] [τ,τ']; ⊢ is,[] [::] τ'#τs ⟧
⟹ ⊢ (i # is),[] [::] τ # τ' # τs"
using wt_instrs_Cons[where ?xt = "[]"]
by (simp add:shift_def)
declare nth_append[simp del]
declare [[simproc del: list_to_set_comprehension]]
lemma (in TC2) wt_instrs_xapp[trans]:
"⟦ ⊢ is⇩1 @ is⇩2, xt [::] τs⇩1 @ ty⇩i' (Class C # ST) E A # τs⇩2;
∀τ ∈ set τs⇩1. ∀ST' LT'. τ = Some(ST',LT') ⟶
size ST ≤ size ST' ∧ P ⊢ Some (drop (size ST' - size ST) ST',LT') ≤' ty⇩i' ST E A;
size is⇩1 = size τs⇩1; is_class P C; size ST < mxs ⟧ ⟹
⊢ is⇩1 @ is⇩2, xt @ [(0,size is⇩1 - 1,C,size is⇩1,size ST)] [::] τs⇩1 @ ty⇩i' (Class C # ST) E A # τs⇩2"
apply(simp add:wt_instrs_def)
apply(rule conjI)
apply(clarsimp)
apply arith
apply clarsimp
apply(erule allE, erule (1) impE)
apply(clarsimp simp add: wt_instr_def app_def eff_def)
apply(rule conjI)
apply (thin_tac "∀x∈ A ∪ B. P x" for A B P)
apply (thin_tac "∀x∈ A ∪ B. P x" for A B P)
apply (clarsimp simp add: xcpt_app_def relevant_entries_def)
apply (simp add: nth_append is_relevant_entry_def split!: if_splits)
apply (drule_tac x="τs⇩1!pc" in bspec)
apply (blast intro: nth_mem)
apply fastforce
apply (rule conjI)
apply clarsimp
apply (erule disjE, blast)
apply (erule disjE, blast)
apply (clarsimp simp add: xcpt_eff_def relevant_entries_def split: if_split_asm)
apply clarsimp
apply (erule disjE, blast)
apply (erule disjE, blast)
apply (clarsimp simp add: xcpt_eff_def relevant_entries_def split: if_split_asm)
apply (simp add: nth_append is_relevant_entry_def split: if_split_asm)
apply (drule_tac x = "τs⇩1!pc" in bspec)
apply (blast intro: nth_mem)
apply (fastforce simp add: ty⇩i'_def)
done
declare [[simproc add: list_to_set_comprehension]]
declare nth_append[simp]
lemma drop_Cons_Suc:
"⋀xs. drop n xs = y#ys ⟹ drop (Suc n) xs = ys"
apply (induct n)
apply simp
apply (simp add: drop_Suc)
done
lemma drop_mess:
"⟦Suc (length xs⇩0) ≤ length xs; drop (length xs - Suc (length xs⇩0)) xs = x # xs⇩0⟧
⟹ drop (length xs - length xs⇩0) xs = xs⇩0"
apply (cases xs)
apply simp
apply (simp add: Suc_diff_le)
apply (case_tac "length list - length xs⇩0")
apply simp
apply (simp add: drop_Cons_Suc)
done
declare (in TC0)
after_def[simp] pair_eq_ty⇩i'_conv[simp]
lemma (in TC1) compT_ST_prefix:
"⋀E A ST⇩0. ⌊(ST,LT)⌋ ∈ set(compT E A ST⇩0 e) ⟹
size ST⇩0 ≤ size ST ∧ drop (size ST - size ST⇩0) ST = ST⇩0"
and
"⋀E A ST⇩0. ⌊(ST,LT)⌋ ∈ set(compTs E A ST⇩0 es) ⟹
size ST⇩0 ≤ size ST ∧ drop (size ST - size ST⇩0) ST = ST⇩0"
proof(induct e and es rule: compT.induct compTs.induct)
case (FAss e⇩1 F D e⇩2)
moreover {
let ?ST⇩0 = "ty E e⇩1 # ST⇩0"
fix A assume "⌊(ST, LT)⌋ ∈ set (compT E A ?ST⇩0 e⇩2)"
with FAss
have "length ?ST⇩0 ≤ length ST ∧ drop (size ST - size ?ST⇩0) ST = ?ST⇩0" by blast
hence ?case by (clarsimp simp add: drop_mess)
}
ultimately show ?case by auto
next
case TryCatch thus ?case by auto
next
case Block thus ?case by auto
next
case Seq thus ?case by auto
next
case While thus ?case by auto
next
case Cond thus ?case by auto
next
case (Call e M es)
moreover {
let ?ST⇩0 = "ty E e # ST⇩0"
fix A assume "⌊(ST, LT)⌋ ∈ set (compTs E A ?ST⇩0 es)"
with Call
have "length ?ST⇩0 ≤ length ST ∧ drop (size ST - size ?ST⇩0) ST = ?ST⇩0" by blast
hence ?case by (clarsimp simp add: drop_mess)
}
ultimately show ?case by auto
next
case (Cons_exp e es)
moreover {
let ?ST⇩0 = "ty E e # ST⇩0"
fix A assume "⌊(ST, LT)⌋ ∈ set (compTs E A ?ST⇩0 es)"
with Cons_exp
have "length ?ST⇩0 ≤ length ST ∧ drop (size ST - size ?ST⇩0) ST = ?ST⇩0" by blast
hence ?case by (clarsimp simp add: drop_mess)
}
ultimately show ?case by auto
next
case (BinOp e⇩1 bop e⇩2)
moreover {
let ?ST⇩0 = "ty E e⇩1 # ST⇩0"
fix A assume "⌊(ST, LT)⌋ ∈ set (compT E A ?ST⇩0 e⇩2)"
with BinOp
have "length ?ST⇩0 ≤ length ST ∧ drop (size ST - size ?ST⇩0) ST = ?ST⇩0" by blast
hence ?case by (clarsimp simp add: drop_mess)
}
ultimately show ?case by auto
next
case new thus ?case by auto
next
case Val thus ?case by auto
next
case Cast thus ?case by auto
next
case Var thus ?case by auto
next
case LAss thus ?case by auto
next
case throw thus ?case by auto
next
case FAcc thus ?case by auto
next
case Nil_exp thus ?case by auto
qed
declare (in TC0)
after_def[simp del] pair_eq_ty⇩i'_conv[simp del]
lemma fun_of_simp [simp]: "fun_of S x y = ((x,y) ∈ S)"
by (simp add: fun_of_def)
theorem (in TC2) compT_wt_instrs: "⋀E T A ST.
⟦ P,E ⊢⇩1 e :: T; 𝒟 e A; ℬ e (size E);
size ST + max_stack e ≤ mxs; size E + max_vars e ≤ mxl ⟧
⟹ ⊢ compE⇩2 e, compxE⇩2 e 0 (size ST) [::]
ty⇩i' ST E A # compT E A ST e @ [after E A ST e]"
(is "⋀E T A ST. PROP ?P e E T A ST")
and "⋀E Ts A ST.
⟦ P,E ⊢⇩1 es[::]Ts; 𝒟s es A; ℬs es (size E);
size ST + max_stacks es ≤ mxs; size E + max_varss es ≤ mxl ⟧
⟹ let τs = ty⇩i' ST E A # compTs E A ST es in
⊢ compEs⇩2 es,compxEs⇩2 es 0 (size ST) [::] τs ∧
last τs = ty⇩i' (rev Ts @ ST) E (A ⊔ 𝒜s es)"
(is "⋀E Ts A ST. PROP ?Ps es E Ts A ST")
proof(induct e and es rule: compxE⇩2.induct compxEs⇩2.induct)
case (TryCatch e⇩1 C i e⇩2)
hence [simp]: "i = size E" by simp
have wt⇩1: "P,E ⊢⇩1 e⇩1 :: T" and wt⇩2: "P,E@[Class C] ⊢⇩1 e⇩2 :: T"
and "class": "is_class P C" using TryCatch by auto
let ?A⇩1 = "A ⊔ 𝒜 e⇩1" let ?A⇩i = "A ⊔ ⌊{i}⌋" let ?E⇩i = "E @ [Class C]"
let ?τ = "ty⇩i' ST E A" let ?τs⇩1 = "compT E A ST e⇩1"
let ?τ⇩1 = "ty⇩i' (T#ST) E ?A⇩1" let ?τ⇩2 = "ty⇩i' (Class C#ST) E A"
let ?τ⇩3 = "ty⇩i' ST ?E⇩i ?A⇩i" let ?τs⇩2 = "compT ?E⇩i ?A⇩i ST e⇩2"
let ?τ⇩2' = "ty⇩i' (T#ST) ?E⇩i (?A⇩i ⊔ 𝒜 e⇩2)"
let ?τ' = "ty⇩i' (T#ST) E (A ⊔ 𝒜 e⇩1 ⊓ (𝒜 e⇩2 ⊖ i))"
let ?go = "Goto (int(size(compE⇩2 e⇩2)) + 2)"
have "PROP ?P e⇩2 ?E⇩i T ?A⇩i ST" by fact
hence "⊢ compE⇩2 e⇩2,compxE⇩2 e⇩2 0 (size ST) [::] (?τ⇩3 # ?τs⇩2) @ [?τ⇩2']"
using TryCatch.prems by(auto simp:after_def)
also have "?A⇩i ⊔ 𝒜 e⇩2 = (A ⊔ 𝒜 e⇩2) ⊔ ⌊{size E}⌋"
by(fastforce simp:hyperset_defs)
also have "P ⊢ ty⇩i' (T#ST) ?E⇩i … ≤' ty⇩i' (T#ST) E (A ⊔ 𝒜 e⇩2)"
by(simp add:hyperset_defs ty⇩l_incr ty⇩i'_def)
also have "P ⊢ … ≤' ty⇩i' (T#ST) E (A ⊔ 𝒜 e⇩1 ⊓ (𝒜 e⇩2 ⊖ i))"
by(auto intro!: ty⇩l_antimono simp:hyperset_defs ty⇩i'_def)
also have "(?τ⇩3 # ?τs⇩2) @ [?τ'] = ?τ⇩3 # ?τs⇩2 @ [?τ']" by simp
also have "⊢ [Store i],[] [::] ?τ⇩2 # [] @ [?τ⇩3]"
using TryCatch.prems
by(auto simp:nth_list_update wt_defs ty⇩i'_def ty⇩l_def
list_all2_conv_all_nth hyperset_defs)
also have "[] @ (?τ⇩3 # ?τs⇩2 @ [?τ']) = (?τ⇩3 # ?τs⇩2 @ [?τ'])" by simp
also have "P,T⇩r,mxs,size(compE⇩2 e⇩2)+3,[] ⊢ ?go,0 :: ?τ⇩1#?τ⇩2#?τ⇩3#?τs⇩2 @ [?τ']"
by (auto simp: hyperset_defs ty⇩i'_def wt_defs nth_Cons nat_add_distrib
fun_of_def intro: ty⇩l_antimono list_all2_refl split:nat.split)
also have "⊢ compE⇩2 e⇩1,compxE⇩2 e⇩1 0 (size ST) [::] ?τ # ?τs⇩1 @ [?τ⇩1]"
using TryCatch by(auto simp:after_def)
also have "?τ # ?τs⇩1 @ ?τ⇩1 # ?τ⇩2 # ?τ⇩3 # ?τs⇩2 @ [?τ'] =
(?τ # ?τs⇩1 @ [?τ⇩1]) @ ?τ⇩2 # ?τ⇩3 # ?τs⇩2 @ [?τ']" by simp
also have "compE⇩2 e⇩1 @ ?go # [Store i] @ compE⇩2 e⇩2 =
(compE⇩2 e⇩1 @ [?go]) @ (Store i # compE⇩2 e⇩2)" by simp
also
let "?Q τ" = "∀ST' LT'. τ = ⌊(ST', LT')⌋ ⟶
size ST ≤ size ST' ∧ P ⊢ Some (drop (size ST' - size ST) ST',LT') ≤' ty⇩i' ST E A"
{
have "?Q (ty⇩i' ST E A)" by (clarsimp simp add: ty⇩i'_def)
moreover have "?Q (ty⇩i' (T # ST) E ?A⇩1)"
by (fastforce simp add: ty⇩i'_def hyperset_defs intro!: ty⇩l_antimono)
moreover have "⋀τ. τ ∈ set (compT E A ST e⇩1) ⟹ ?Q τ" using TryCatch.prems
by clarsimp (frule compT_ST_prefix,
fastforce dest!: compT_LT_prefix simp add: ty⇩i'_def)
ultimately
have "∀τ∈set (ty⇩i' ST E A # compT E A ST e⇩1 @ [ty⇩i' (T # ST) E ?A⇩1]). ?Q τ"
by auto
}
also from TryCatch.prems max_stack1[of e⇩1] have "size ST + 1 ≤ mxs" by auto
ultimately show ?case using wt⇩1 wt⇩2 TryCatch.prems "class"
by (simp add:after_def)
next
case new thus ?case by(auto simp add:after_def wt_New)
next
case (BinOp e⇩1 bop e⇩2)
let ?op = "case bop of Eq ⇒ [CmpEq] | Add ⇒ [IAdd]"
have T: "P,E ⊢⇩1 e⇩1 «bop» e⇩2 :: T" by fact
then obtain T⇩1 T⇩2 where T⇩1: "P,E ⊢⇩1 e⇩1 :: T⇩1" and T⇩2: "P,E ⊢⇩1 e⇩2 :: T⇩2" and
bopT: "case bop of Eq ⇒ (P ⊢ T⇩1 ≤ T⇩2 ∨ P ⊢ T⇩2 ≤ T⇩1) ∧ T = Boolean
| Add ⇒ T⇩1 = Integer ∧ T⇩2 = Integer ∧ T = Integer" by auto
let ?A⇩1 = "A ⊔ 𝒜 e⇩1" let ?A⇩2 = "?A⇩1 ⊔ 𝒜 e⇩2"
let ?τ = "ty⇩i' ST E A" let ?τs⇩1 = "compT E A ST e⇩1"
let ?τ⇩1 = "ty⇩i' (T⇩1#ST) E ?A⇩1" let ?τs⇩2 = "compT E ?A⇩1 (T⇩1#ST) e⇩2"
let ?τ⇩2 = "ty⇩i' (T⇩2#T⇩1#ST) E ?A⇩2" let ?τ' = "ty⇩i' (T#ST) E ?A⇩2"
from bopT have "⊢ ?op,[] [::] [?τ⇩2,?τ']"
by (cases bop) (auto simp add: wt_CmpEq wt_IAdd)
also have "PROP ?P e⇩2 E T⇩2 ?A⇩1 (T⇩1#ST)" by fact
with BinOp.prems T⇩2
have "⊢ compE⇩2 e⇩2, compxE⇩2 e⇩2 0 (size (T⇩1#ST)) [::] ?τ⇩1#?τs⇩2@[?τ⇩2]"
by (auto simp: after_def)
also from BinOp T⇩1 have "⊢ compE⇩2 e⇩1, compxE⇩2 e⇩1 0 (size ST) [::] ?τ#?τs⇩1@[?τ⇩1]"
by (auto simp: after_def)
finally show ?case using T T⇩1 T⇩2 by (simp add: after_def hyperUn_assoc)
next
case (Cons_exp e es)
have "P,E ⊢⇩1 e # es [::] Ts" by fact
then obtain T⇩e Ts' where
T⇩e: "P,E ⊢⇩1 e :: T⇩e" and Ts': "P,E ⊢⇩1 es [::] Ts'" and
Ts: "Ts = T⇩e#Ts'" by auto
let ?A⇩e = "A ⊔ 𝒜 e"
let ?τ = "ty⇩i' ST E A" let ?τs⇩e = "compT E A ST e"
let ?τ⇩e = "ty⇩i' (T⇩e#ST) E ?A⇩e" let ?τs' = "compTs E ?A⇩e (T⇩e#ST) es"
let ?τs = "?τ # ?τs⇩e @ (?τ⇩e # ?τs')"
have Ps: "PROP ?Ps es E Ts' ?A⇩e (T⇩e#ST)" by fact
with Cons_exp.prems T⇩e Ts'
have "⊢ compEs⇩2 es, compxEs⇩2 es 0 (size (T⇩e#ST)) [::] ?τ⇩e#?τs'" by (simp add: after_def)
also from Cons_exp T⇩e have "⊢ compE⇩2 e, compxE⇩2 e 0 (size ST) [::] ?τ#?τs⇩e@[?τ⇩e]"
by (auto simp: after_def)
moreover
from Ps Cons_exp.prems T⇩e Ts' Ts
have "last ?τs = ty⇩i' (rev Ts@ST) E (?A⇩e ⊔ 𝒜s es)" by simp
ultimately show ?case using T⇩e by (simp add: after_def hyperUn_assoc)
next
case (FAss e⇩1 F D e⇩2)
hence Void: "P,E ⊢⇩1 e⇩1∙F{D} := e⇩2 :: Void" by auto
then obtain C T T' where
C: "P,E ⊢⇩1 e⇩1 :: Class C" and sees: "P ⊢ C sees F:T in D" and
T': "P,E ⊢⇩1 e⇩2 :: T'" and T'_T: "P ⊢ T' ≤ T" by auto
let ?A⇩1 = "A ⊔ 𝒜 e⇩1" let ?A⇩2 = "?A⇩1 ⊔ 𝒜 e⇩2"
let ?τ = "ty⇩i' ST E A" let ?τs⇩1 = "compT E A ST e⇩1"
let ?τ⇩1 = "ty⇩i' (Class C#ST) E ?A⇩1" let ?τs⇩2 = "compT E ?A⇩1 (Class C#ST) e⇩2"
let ?τ⇩2 = "ty⇩i' (T'#Class C#ST) E ?A⇩2" let ?τ⇩3 = "ty⇩i' ST E ?A⇩2"
let ?τ' = "ty⇩i' (Void#ST) E ?A⇩2"
from FAss.prems sees T'_T
have "⊢ [Putfield F D,Push Unit],[] [::] [?τ⇩2,?τ⇩3,?τ']"
by (fastforce simp add: wt_Push wt_Put)
also have "PROP ?P e⇩2 E T' ?A⇩1 (Class C#ST)" by fact
with FAss.prems T'
have "⊢ compE⇩2 e⇩2, compxE⇩2 e⇩2 0 (size ST+1) [::] ?τ⇩1#?τs⇩2@[?τ⇩2]"
by (auto simp add: after_def hyperUn_assoc)
also from FAss C have "⊢ compE⇩2 e⇩1, compxE⇩2 e⇩1 0 (size ST) [::] ?τ#?τs⇩1@[?τ⇩1]"
by (auto simp add: after_def)
finally show ?case using Void C T' by (simp add: after_def hyperUn_assoc)
next
case Val thus ?case by(auto simp:after_def wt_Push)
next
case Cast thus ?case by (auto simp:after_def wt_Cast)
next
case (Block i T⇩i e)
let ?τs = "ty⇩i' ST E A # compT (E @ [T⇩i]) (A⊖i) ST e"
have IH: "PROP ?P e (E@[T⇩i]) T (A⊖i) ST" by fact
hence "⊢ compE⇩2 e, compxE⇩2 e 0 (size ST) [::]
?τs @ [ty⇩i' (T#ST) (E@[T⇩i]) (A⊖(size E) ⊔ 𝒜 e)]"
using Block.prems by (auto simp add: after_def)
also have "P ⊢ ty⇩i' (T # ST) (E@[T⇩i]) (A ⊖ size E ⊔ 𝒜 e) ≤'
ty⇩i' (T # ST) (E@[T⇩i]) ((A ⊔ 𝒜 e) ⊖ size E)"
by(auto simp add:hyperset_defs intro: ty⇩i'_antimono)
also have "… = ty⇩i' (T # ST) E (A ⊔ 𝒜 e)" by simp
also have "P ⊢ … ≤' ty⇩i' (T # ST) E (A ⊔ (𝒜 e ⊖ i))"
by(auto simp add:hyperset_defs intro: ty⇩i'_antimono)
finally show ?case using Block.prems by(simp add: after_def)
next
case Var thus ?case by(auto simp:after_def wt_Load)
next
case FAcc thus ?case by(auto simp:after_def wt_Get)
next
case (LAss i e) thus ?case using max_stack1[of e]
by(auto simp: hyper_insert_comm after_def wt_Store wt_Push)
next
case Nil_exp thus ?case by auto
next
case throw thus ?case by(auto simp add: after_def wt_Throw)
next
case (While e c)
obtain Tc where wte: "P,E ⊢⇩1 e :: Boolean" and wtc: "P,E ⊢⇩1 c :: Tc"
and [simp]: "T = Void" using While by auto
have [simp]: "ty E (while (e) c) = Void" using While by simp
let ?A⇩0 = "A ⊔ 𝒜 e" let ?A⇩1 = "?A⇩0 ⊔ 𝒜 c"
let ?τ = "ty⇩i' ST E A" let ?τs⇩e = "compT E A ST e"
let ?τ⇩e = "ty⇩i' (Boolean#ST) E ?A⇩0" let ?τ⇩1 = "ty⇩i' ST E ?A⇩0"
let ?τs⇩c = "compT E ?A⇩0 ST c" let ?τ⇩c = "ty⇩i' (Tc#ST) E ?A⇩1"
let ?τ⇩2 = "ty⇩i' ST E ?A⇩1" let ?τ' = "ty⇩i' (Void#ST) E ?A⇩0"
let ?τs = "(?τ # ?τs⇩e @ [?τ⇩e]) @ ?τ⇩1 # ?τs⇩c @ [?τ⇩c, ?τ⇩2, ?τ⇩1, ?τ']"
have "⊢ [],[] [::] [] @ ?τs" by(simp add:wt_instrs_def)
also
have "PROP ?P e E Boolean A ST" by fact
hence "⊢ compE⇩2 e,compxE⇩2 e 0 (size ST) [::] ?τ # ?τs⇩e @ [?τ⇩e]"
using While.prems by (auto simp:after_def)
also
have "[] @ ?τs = (?τ # ?τs⇩e) @ ?τ⇩e # ?τ⇩1 # ?τs⇩c @ [?τ⇩c,?τ⇩2,?τ⇩1,?τ']" by simp
also
let ?n⇩e = "size(compE⇩2 e)" let ?n⇩c = "size(compE⇩2 c)"
let ?if = "IfFalse (int ?n⇩c + 3)"
have "⊢ [?if],[] [::] ?τ⇩e # ?τ⇩1 # ?τs⇩c @ [?τ⇩c, ?τ⇩2, ?τ⇩1, ?τ']"
by(simp add: wt_instr_Cons wt_instr_append wt_IfFalse
nat_add_distrib split: nat_diff_split)
also
have "(?τ # ?τs⇩e) @ (?τ⇩e # ?τ⇩1 # ?τs⇩c @ [?τ⇩c, ?τ⇩2, ?τ⇩1, ?τ']) = ?τs" by simp
also
have "PROP ?P c E Tc ?A⇩0 ST" by fact
hence "⊢ compE⇩2 c,compxE⇩2 c 0 (size ST) [::] ?τ⇩1 # ?τs⇩c @ [?τ⇩c]"
using While.prems wtc by (auto simp:after_def)
also have "?τs = (?τ # ?τs⇩e @ [?τ⇩e,?τ⇩1] @ ?τs⇩c) @ [?τ⇩c,?τ⇩2,?τ⇩1,?τ']" by simp
also have "⊢ [Pop],[] [::] [?τ⇩c, ?τ⇩2]" by(simp add:wt_Pop)
also have "(?τ # ?τs⇩e @ [?τ⇩e,?τ⇩1] @ ?τs⇩c) @ [?τ⇩c,?τ⇩2,?τ⇩1,?τ'] = ?τs" by simp
also let ?go = "Goto (-int(?n⇩c+?n⇩e+2))"
have "P ⊢ ?τ⇩2 ≤' ?τ" by(fastforce intro: ty⇩i'_antimono simp: hyperset_defs)
hence "P,T⇩r,mxs,size ?τs,[] ⊢ ?go,?n⇩e+?n⇩c+2 :: ?τs"
by(simp add: wt_Goto split: nat_diff_split)
also have "?τs = (?τ # ?τs⇩e @ [?τ⇩e,?τ⇩1] @ ?τs⇩c @ [?τ⇩c, ?τ⇩2]) @ [?τ⇩1, ?τ']"
by simp
also have "⊢ [Push Unit],[] [::] [?τ⇩1,?τ']"
using While.prems max_stack1[of c] by(auto simp add:wt_Push)
finally show ?case using wtc wte
by (simp add:after_def)
next
case (Cond e e⇩1 e⇩2)
obtain T⇩1 T⇩2 where wte: "P,E ⊢⇩1 e :: Boolean"
and wt⇩1: "P,E ⊢⇩1 e⇩1 :: T⇩1" and wt⇩2: "P,E ⊢⇩1 e⇩2 :: T⇩2"
and sub⇩1: "P ⊢ T⇩1 ≤ T" and sub⇩2: "P ⊢ T⇩2 ≤ T"
using Cond by auto
have [simp]: "ty E (if (e) e⇩1 else e⇩2) = T" using Cond by simp
let ?A⇩0 = "A ⊔ 𝒜 e" let ?A⇩2 = "?A⇩0 ⊔ 𝒜 e⇩2" let ?A⇩1 = "?A⇩0 ⊔ 𝒜 e⇩1"
let ?A' = "?A⇩0 ⊔ 𝒜 e⇩1 ⊓ 𝒜 e⇩2"
let ?τ⇩2 = "ty⇩i' ST E ?A⇩0" let ?τ' = "ty⇩i' (T#ST) E ?A'"
let ?τs⇩2 = "compT E ?A⇩0 ST e⇩2"
have "PROP ?P e⇩2 E T⇩2 ?A⇩0 ST" by fact
hence "⊢ compE⇩2 e⇩2, compxE⇩2 e⇩2 0 (size ST) [::] (?τ⇩2#?τs⇩2) @ [ty⇩i' (T⇩2#ST) E ?A⇩2]"
using Cond.prems wt⇩2 by(auto simp add:after_def)
also have "P ⊢ ty⇩i' (T⇩2#ST) E ?A⇩2 ≤' ?τ'" using sub⇩2
by(auto simp add: hyperset_defs ty⇩i'_def intro!: ty⇩l_antimono)
also
let ?τ⇩3 = "ty⇩i' (T⇩1 # ST) E ?A⇩1"
let ?g⇩2 = "Goto(int (size (compE⇩2 e⇩2) + 1))"
from sub⇩1 have "P,T⇩r,mxs,size(compE⇩2 e⇩2)+2,[] ⊢ ?g⇩2,0 :: ?τ⇩3#(?τ⇩2#?τs⇩2)@[?τ']"
by(auto simp: hyperset_defs wt_defs nth_Cons ty⇩i'_def
split:nat.split intro!: ty⇩l_antimono)
also
let ?τs⇩1 = "compT E ?A⇩0 ST e⇩1"
have "PROP ?P e⇩1 E T⇩1 ?A⇩0 ST" by fact
hence "⊢ compE⇩2 e⇩1,compxE⇩2 e⇩1 0 (size ST) [::] ?τ⇩2 # ?τs⇩1 @ [?τ⇩3]"
using Cond.prems wt⇩1 by(auto simp add:after_def)
also
let ?τs⇩1⇩2 = "?τ⇩2 # ?τs⇩1 @ ?τ⇩3 # (?τ⇩2 # ?τs⇩2) @ [?τ']"
let ?τ⇩1 = "ty⇩i' (Boolean#ST) E ?A⇩0"
let ?g⇩1 = "IfFalse(int (size (compE⇩2 e⇩1) + 2))"
let ?code = "compE⇩2 e⇩1 @ ?g⇩2 # compE⇩2 e⇩2"
have "⊢ [?g⇩1],[] [::] [?τ⇩1] @ ?τs⇩1⇩2"
by(simp add: wt_IfFalse nat_add_distrib split:nat_diff_split)
also (wt_instrs_ext2) have "[?τ⇩1] @ ?τs⇩1⇩2 = ?τ⇩1 # ?τs⇩1⇩2" by simp also
let ?τ = "ty⇩i' ST E A"
have "PROP ?P e E Boolean A ST" by fact
hence "⊢ compE⇩2 e, compxE⇩2 e 0 (size ST) [::] ?τ # compT E A ST e @ [?τ⇩1]"
using Cond.prems wte by(auto simp add:after_def)
finally show ?case using wte wt⇩1 wt⇩2 by(simp add:after_def hyperUn_assoc)
next
case (Call e M es)
obtain C D Ts m Ts' where C: "P,E ⊢⇩1 e :: Class C"
and "method": "P ⊢ C sees M:Ts → T = m in D"
and wtes: "P,E ⊢⇩1 es [::] Ts'" and subs: "P ⊢ Ts' [≤] Ts"
using Call.prems by auto
from wtes have same_size: "size es = size Ts'" by(rule WTs⇩1_same_size)
let ?A⇩0 = "A ⊔ 𝒜 e" let ?A⇩1 = "?A⇩0 ⊔ 𝒜s es"
let ?τ = "ty⇩i' ST E A" let ?τs⇩e = "compT E A ST e"
let ?τ⇩e = "ty⇩i' (Class C # ST) E ?A⇩0"
let ?τs⇩e⇩s = "compTs E ?A⇩0 (Class C # ST) es"
let ?τ⇩1 = "ty⇩i' (rev Ts' @ Class C # ST) E ?A⇩1"
let ?τ' = "ty⇩i' (T # ST) E ?A⇩1"
have "⊢ [Invoke M (size es)],[] [::] [?τ⇩1,?τ']"
by(rule wt_Invoke[OF same_size "method" subs])
also
have "PROP ?Ps es E Ts' ?A⇩0 (Class C # ST)" by fact
hence "⊢ compEs⇩2 es,compxEs⇩2 es 0 (size ST+1) [::] ?τ⇩e # ?τs⇩e⇩s"
"last (?τ⇩e # ?τs⇩e⇩s) = ?τ⇩1"
using Call.prems wtes by(auto simp add:after_def)
also have "(?τ⇩e # ?τs⇩e⇩s) @ [?τ'] = ?τ⇩e # ?τs⇩e⇩s @ [?τ']" by simp
also have "⊢ compE⇩2 e,compxE⇩2 e 0 (size ST) [::] ?τ # ?τs⇩e @ [?τ⇩e]"
using Call C by(auto simp add:after_def)
finally show ?case using Call.prems C by(simp add:after_def hyperUn_assoc)
next
case Seq thus ?case
by(auto simp:after_def)
(fastforce simp:wt_Push wt_Pop hyperUn_assoc
intro:wt_instrs_app2 wt_instrs_Cons)
qed
lemma [simp]: "types (compP f P) = types P"
by auto
lemma [simp]: "states (compP f P) mxs mxl = states P mxs mxl"
by (simp add: JVM_states_unfold)
lemma [simp]: "app⇩i (i, compP f P, pc, mpc, T, τ) = app⇩i (i, P, pc, mpc, T, τ)"
apply (cases τ)
apply (cases i)
apply auto
apply (fastforce dest!: sees_method_compPD)
apply (force dest: sees_method_compP)
done
lemma [simp]: "is_relevant_entry (compP f P) i = is_relevant_entry P i"
apply (rule ext)+
apply (unfold is_relevant_entry_def)
apply (cases i)
apply auto
done
lemma [simp]: "relevant_entries (compP f P) i pc xt = relevant_entries P i pc xt"
by (simp add: relevant_entries_def)
lemma [simp]: "app i (compP f P) mpc T pc mxl xt τ = app i P mpc T pc mxl xt τ"
apply (simp add: app_def xcpt_app_def eff_def xcpt_eff_def norm_eff_def)
apply (fastforce simp add: image_def)
done
lemma [simp]: "app i P mpc T pc mxl xt τ ⟹ eff i (compP f P) pc xt τ = eff i P pc xt τ"
apply (clarsimp simp add: eff_def norm_eff_def xcpt_eff_def app_def)
apply (cases i)
apply auto
done
lemma [simp]: "subtype (compP f P) = subtype P"
apply (rule ext)+
apply (simp)
done
lemma [simp]: "compP f P ⊢ τ ≤' τ' = P ⊢ τ ≤' τ'"
by (simp add: sup_state_opt_def sup_state_def sup_ty_opt_def)
lemma [simp]: "compP f P,T,mpc,mxl,xt ⊢ i,pc :: τs = P,T,mpc,mxl,xt ⊢ i,pc :: τs"
by (simp add: wt_instr_def cong: conj_cong)
declare TC1.compT_sizes[simp] TC0.ty_def2[simp]
context TC2
begin
lemma compT_method:
fixes e and A and C and Ts and mxl⇩0
defines [simp]: "E ≡ Class C # Ts"
and [simp]: "A ≡ ⌊{..size Ts}⌋"
and [simp]: "A' ≡ A ⊔ 𝒜 e"
and [simp]: "mxl⇩0 ≡ max_vars e"
assumes mxs: "max_stack e = mxs"
and mxl: "Suc (length Ts + max_vars e) = mxl"
assumes assm: "wf_prog p P" "P,E ⊢⇩1 e :: T" "𝒟 e A" "ℬ e (size E)"
"set E ⊆ types P" "P ⊢ T ≤ T⇩r"
shows "wt_method (compP⇩2 P) C Ts T⇩r mxs mxl⇩0 (compE⇩2 e @ [Return])
(compxE⇩2 e 0 0) (ty⇩i' [] E A # compT⇩a E A [] e)"
using assms apply (simp add: wt_method_def compT⇩a_def after_def mxl)
apply (rule conjI)
apply (simp add: check_types_def OK_ty⇩i'_in_statesI)
apply (rule conjI)
apply (drule (1) WT⇩1_is_type)
apply simp
apply (insert max_stack1 [of e])
apply (rule OK_ty⇩i'_in_statesI) apply (simp_all add: mxs)[3]
apply (erule compT_states(1))
apply assumption
apply (simp_all add: mxs mxl)[4]
apply (rule conjI)
apply (auto simp add: wt_start_def ty⇩i'_def ty⇩l_def list_all2_conv_all_nth
nth_Cons mxl split: nat.split dest: less_antisym)[1]
apply (frule (1) TC2.compT_wt_instrs [of P _ _ _ _ "[]" "max_stack e" "Suc (length Ts + max_vars e)" T⇩r])
apply simp_all
apply (clarsimp simp: after_def)
apply hypsubst_thin
apply (rule conjI)
apply (clarsimp simp: wt_instrs_def after_def mxl mxs)
apply clarsimp
apply (drule (1) less_antisym)
apply (clarsimp simp: wt_defs xcpt_app_pcs xcpt_eff_pcs ty⇩i'_def)
done
end
definition compTP :: "J⇩1_prog ⇒ ty⇩P" where
"compTP P C M = (
let (D,Ts,T,e) = method P C M;
E = Class C # Ts;
A = ⌊{..size Ts}⌋;
mxl = 1 + size Ts + max_vars e
in (TC0.ty⇩i' mxl [] E A # TC1.compT⇩a P mxl E A [] e))"
theorem wt_compP⇩2:
"wf_J⇩1_prog P ⟹ wf_jvm_prog (compP⇩2 P)"
apply (simp add: wf_jvm_prog_def wf_jvm_prog_phi_def)
apply(rule_tac x = "compTP P" in exI)
apply (rule wf_prog_compPI)
prefer 2 apply assumption
apply (clarsimp simp add: wf_mdecl_def)
apply (simp add: compTP_def)
apply (rule TC2.compT_method [simplified])
apply (rule refl)
apply (rule refl)
apply assumption
apply assumption
apply assumption
apply assumption
apply (drule (1) sees_wf_mdecl)
apply (simp add: wf_mdecl_def)
apply (blast intro: sees_method_is_class)
apply assumption
done
theorem wt_J2JVM:
"wf_J_prog P ⟹ wf_jvm_prog (J2JVM P)"
apply(simp only:o_def J2JVM_def)
apply(blast intro:wt_compP⇩2 compP⇩1_pres_wf)
done
end